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 (projectee : fragment_progress) : Prims.bool=
  match projectee with | FullBufferStarted -> true | uu___ -> false
let uu___is_FragmentStarted (projectee : fragment_progress) : Prims.bool=
  match projectee with | FragmentStarted _0 -> true | uu___ -> false
let __proj__FragmentStarted__item___0 (projectee : fragment_progress) :
  FStarC_Parser_AST.decl= match projectee with | FragmentStarted _0 -> _0
let uu___is_FragmentSuccess (projectee : fragment_progress) : Prims.bool=
  match projectee with | FragmentSuccess _0 -> true | uu___ -> false
let __proj__FragmentSuccess__item___0 (projectee : fragment_progress) :
  (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment *
    FStarC_Interactive_Ide_Types.push_kind)=
  match projectee with | FragmentSuccess _0 -> _0
let uu___is_FragmentFailed (projectee : fragment_progress) : Prims.bool=
  match projectee with | FragmentFailed _0 -> true | uu___ -> false
let __proj__FragmentFailed__item___0 (projectee : fragment_progress) :
  FStarC_Parser_AST.decl= match projectee with | FragmentFailed _0 -> _0
let uu___is_FragmentError (projectee : fragment_progress) : Prims.bool=
  match projectee with | FragmentError _0 -> true | uu___ -> false
let __proj__FragmentError__item___0 (projectee : fragment_progress) :
  FStarC_Errors.issue Prims.list=
  match projectee with | FragmentError _0 -> _0
let uu___is_FullBufferFinished (projectee : fragment_progress) : Prims.bool=
  match projectee with | FullBufferFinished -> true | uu___ -> false
let dbg : Prims.bool FStarC_Effect.ref= FStarC_Debug.get_toggle "IDE"
type qid = (Prims.string * Prims.int)
type 'a qst = (qid * FStarC_Interactive_Ide_Types.repl_state) -> ('a * qid)
let return (x : 'a) : 'a qst=
  fun uu___ -> match uu___ with | (q, uu___1) -> (x, q)
let op_let_Bang (f : 'a qst) (g : 'a -> 'b qst) : 'b qst=
  fun uu___ ->
    match uu___ with
    | (q, s) ->
        let uu___1 = f (q, s) in
        (match uu___1 with | (x, q') -> let uu___2 = g x in uu___2 (q', s))
let run_qst (f : 'a qst) (q : Prims.string)
  (st : FStarC_Interactive_Ide_Types.repl_state) : 'a=
  let uu___ = f ((q, Prims.int_zero), st) in
  FStar_Pervasives_Native.fst uu___
let rec map : 'a 'b . ('a -> 'b qst) -> 'a Prims.list -> 'b Prims.list qst =
  fun f 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 (q : qid) (i : Prims.int) : (Prims.string * Prims.int)=
  ((FStar_Pervasives_Native.fst q), ((FStar_Pervasives_Native.snd q) + i))
let get_filename : Prims.string qst=
  fun uu___ ->
    match uu___ with
    | (q, s) -> ((s.FStarC_Interactive_Ide_Types.repl_fname), q)
let next_qid : qid qst=
  fun uu___ ->
    match uu___ with
    | (q, uu___1) -> let q1 = shift_qid q Prims.int_one in (q1, q1)
let get_qid : qid qst= fun uu___ -> match uu___ with | (q, uu___1) -> (q, q)
let as_query (q : FStarC_Interactive_Ide_Types.query') :
  FStarC_Interactive_Ide_Types.query qst=
  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_Class_Show.show FStarC_Class_Show.showable_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 (l : FStarC_Ident.lident) :
  FStarC_Interactive_Ide_Types.query qst=
  let r = FStarC_Ident.range_of_lid l in
  let start_pos = FStarC_Range_Ops.start_of_range r in
  let end_pos = FStarC_Range_Ops.end_of_range r in
  let start_line = FStarC_Range_Ops.line_of_pos start_pos in
  let start_col = FStarC_Range_Ops.col_of_pos start_pos in
  let end_line = FStarC_Range_Ops.line_of_pos end_pos in
  let end_col = FStarC_Range_Ops.col_of_pos end_pos in
  op_let_Bang get_filename
    (fun filename ->
       let position = (filename, start_line, start_col) in
       as_query
         (FStarC_Interactive_Ide_Types.Lookup
            ((FStarC_Ident.string_of_lid l),
              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 filename));
                    ("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]))])))))
let dump_symbols (d : FStarC_Parser_AST.decl) :
  FStarC_Interactive_Ide_Types.query Prims.list qst=
  let ls = FStarC_Parser_AST_Util.lidents_of_decl d in
  map dump_symbols_for_lid ls
let push_decl (push_kind : FStarC_Interactive_Ide_Types.push_kind)
  (with_symbols : Prims.bool)
  (write_full_buffer_fragment_progress : fragment_progress -> unit)
  (ds : (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment)) :
  FStarC_Interactive_Ide_Types.query Prims.list qst=
  let uu___ = ds in
  match uu___ with
  | (d, s) ->
      let pq =
        {
          FStarC_Interactive_Ide_Types.push_kind = push_kind;
          FStarC_Interactive_Ide_Types.push_line =
            (FStarC_Range_Ops.line_of_pos
               (FStarC_Range_Ops.start_of_range d.FStarC_Parser_AST.drange));
          FStarC_Interactive_Ide_Types.push_column =
            (FStarC_Range_Ops.col_of_pos
               (FStarC_Range_Ops.start_of_range d.FStarC_Parser_AST.drange));
          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
      op_let_Bang (as_query (FStarC_Interactive_Ide_Types.Callback progress))
        (fun cb ->
           op_let_Bang (as_query (FStarC_Interactive_Ide_Types.Push pq))
             (fun push ->
                if with_symbols
                then
                  let uu___1 = dump_symbols d in
                  op_let_Bang uu___1
                    (fun lookups ->
                       return (FStarC_List.op_At [cb; push] lookups))
                else return [cb; push]))
let push_decls (push_kind : FStarC_Interactive_Ide_Types.push_kind)
  (with_symbols : Prims.bool)
  (write_full_buffer_fragment_progress : fragment_progress -> unit)
  (ds :
    (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment) Prims.list)
  : FStarC_Interactive_Ide_Types.query Prims.list qst=
  let uu___ =
    map
      (push_decl push_kind with_symbols write_full_buffer_fragment_progress)
      ds in
  op_let_Bang uu___ (fun qs -> return (FStarC_List.flatten qs))
let repl_task_of_entry (uu___ : ('uuuuu * ('uuuuu1 * 'uuuuu2))) : 'uuuuu1=
  match uu___ with | (uu___1, (p, uu___2)) -> p
let pop_entries
  (e : FStarC_Interactive_Ide_Types.repl_stack_entry_t Prims.list) :
  FStarC_Interactive_Ide_Types.query Prims.list qst=
  map (fun uu___ -> as_query FStarC_Interactive_Ide_Types.Pop) e
let push_kind_geq (pk1 : FStarC_Interactive_Ide_Types.push_kind)
  (pk2 : FStarC_Interactive_Ide_Types.push_kind) : Prims.bool=
  (pk1 = pk2) ||
    (match (pk1, pk2) with
     | (FStarC_Interactive_Ide_Types.FullCheck,
        FStarC_Interactive_Ide_Types.LaxCheck) -> true
     | (FStarC_Interactive_Ide_Types.LaxCheck,
        FStarC_Interactive_Ide_Types.SyntaxCheck) -> true
     | uu___ -> false)
let inspect_repl_stack (s : FStarC_Interactive_Ide_Types.repl_stack_t)
  (ds :
    (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment) Prims.list)
  (push_kind : FStarC_Interactive_Ide_Types.push_kind)
  (with_symbols : Prims.bool)
  (write_full_buffer_fragment_progress : fragment_progress -> unit) :
  (FStarC_Interactive_Ide_Types.query Prims.list * FStarC_Json.json
    Prims.list) qst=
  let entries = FStarC_List.rev s in
  let push_decls1 =
    push_decls push_kind with_symbols write_full_buffer_fragment_progress in
  let uu___ =
    FStarC_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 rec matching_prefix accum lookups entries2 ds1 =
        match (entries2, ds1) with
        | ([], []) -> return (lookups, accum)
        | (e::entries3, d::ds2) ->
            (match repl_task_of_entry 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, uu___3) ->
                 let uu___4 = pop_entries (e :: entries3) in
                 op_let_Bang uu___4
                   (fun pops ->
                      let uu___5 = push_decls1 (d :: ds2) in
                      op_let_Bang uu___5
                        (fun pushes ->
                           return
                             ((FStarC_List.op_At lookups
                                 (FStarC_List.op_At pops pushes)), accum)))
             | FStarC_Interactive_Ide_Types.PushFragment
                 (FStar_Pervasives.Inr d', pk, issues, uu___1) ->
                 let uu___2 =
                   let uu___3 =
                     FStarC_Parser_AST_Diff.eq_decl
                       (FStar_Pervasives_Native.fst d) d' in
                   if uu___3 then push_kind_geq pk push_kind else false in
                 if uu___2
                 then
                   let uu___3 = d in
                   (match uu___3 with
                    | (d1, s1) ->
                        (write_full_buffer_fragment_progress
                           (FragmentSuccess (d1, s1, pk));
                         if with_symbols
                         then
                           (let uu___5 = dump_symbols d1 in
                            op_let_Bang uu___5
                              (fun lookups' ->
                                 matching_prefix
                                   (FStarC_List.op_At issues accum)
                                   (FStarC_List.op_At lookups' lookups)
                                   entries3 ds2))
                         else
                           matching_prefix (FStarC_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_List.op_At pops
                                    (FStarC_List.op_At lookups pushes)),
                                  accum))))
             | uu___1 ->
                 FStarC_Effect.failwith
                   "Impossible: non-push fragment in repl stack during incremental check")
        | ([], ds2) ->
            let uu___1 = push_decls1 ds2 in
            op_let_Bang uu___1
              (fun pushes ->
                 return ((FStarC_List.op_At lookups pushes), accum))
        | (es, []) ->
            let uu___1 = pop_entries es in
            op_let_Bang uu___1
              (fun pops -> return ((FStarC_List.op_At lookups pops), accum)) in
      let uu___1 = matching_prefix [] [] entries1 ds in
      op_let_Bang uu___1
        (fun uu___2 ->
           match uu___2 with | (queries, json) -> return (queries, json))
let reload_deps
  (repl_stack :
    ('uuuuu * (FStarC_Interactive_Ide_Types.repl_task * 'uuuuu1)) Prims.list)
  : FStarC_Interactive_Ide_Types.query Prims.list qst=
  let pop_until_deps entries =
    let uu___ =
      FStarC_Util.prefix_until
        (fun e ->
           match repl_task_of_entry 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) ->
        op_let_Bang (as_query FStarC_Interactive_Ide_Types.Pop)
          (fun pop ->
             let uu___3 = FStarC_List.map (fun uu___4 -> pop) prefix in
             return uu___3) in
  pop_until_deps repl_stack
let parse_code (st : FStarC_Interactive_Ide_Types.repl_state)
  (lang : FStarC_Parser_ParseIt.lang_opts) (code : Prims.string) :
  FStarC_Parser_ParseIt.parse_result=
  let rng =
    FStarC_Interactive_Ide_Types.initial_range
      st.FStarC_Interactive_Ide_Types.repl_fname in
  FStarC_Parser_ParseIt.parse lang
    (FStarC_Parser_ParseIt.Incremental
       {
         FStarC_Parser_ParseIt.frag_fname =
           (FStarC_Range_Ops.file_of_range rng);
         FStarC_Parser_ParseIt.frag_text = code;
         FStarC_Parser_ParseIt.frag_line =
           (FStarC_Range_Ops.line_of_pos
              (FStarC_Range_Ops.start_of_range rng));
         FStarC_Parser_ParseIt.frag_col =
           (FStarC_Range_Ops.col_of_pos (FStarC_Range_Ops.start_of_range rng))
       })
let syntax_issue
  (uu___ :
    (FStarC_Errors_Codes.error_code * FStarC_Errors_Msg.error_message *
      FStarC_Range_Type.t))
  : FStarC_Errors.issue=
  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 (st : FStarC_Interactive_Ide_Types.repl_state)
  (qid1 : Prims.string) (code : Prims.string)
  (request_type : FStarC_Interactive_Ide_Types.full_buffer_request_kind)
  (with_symbols : Prims.bool)
  (write_full_buffer_fragment_progress : fragment_progress -> unit) :
  (FStarC_Interactive_Ide_Types.query Prims.list * FStarC_Json.json
    Prims.list)=
  (let uu___1 = FStarC_Effect.op_Bang dbg in
   if uu___1
   then
     ((let uu___3 =
         FStarC_Class_Show.show
           FStarC_Interactive_Ide_Types.repl_state_showable st in
       FStarC_Format.print1 "run_full_buffer: repl_state=%s\n" uu___3);
      (let uu___3 =
         let uu___4 =
           FStarC_Effect.op_Bang FStarC_Interactive_PushHelper.repl_stack in
         FStarC_Class_Show.show
           (FStarC_Class_Show.show_list
              FStarC_Interactive_Ide_Types.repl_stack_entry_t_showable)
           uu___4 in
       FStarC_Format.print1 "run_full_buffer: repl_stack=%s\n" uu___3))
   else ());
  FStarC_Parser_ParseIt.add_vfs_entry
    st.FStarC_Interactive_Ide_Types.repl_fname code;
  (let parse_result = parse_code st 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___2, line, _col) ->
         FStarC_List.filter
           (fun uu___3 ->
              match uu___3 with
              | (d, uu___4) ->
                  let start =
                    FStarC_Range_Ops.start_of_range
                      d.FStarC_Parser_AST.drange in
                  let start_line = FStarC_Range_Ops.line_of_pos start in
                  start_line <= line) decls
     | FStarC_Interactive_Ide_Types.LaxToPosition (uu___2, line, _col) ->
         FStarC_List.filter
           (fun uu___3 ->
              match uu___3 with
              | (d, uu___4) ->
                  let start =
                    FStarC_Range_Ops.start_of_range
                      d.FStarC_Parser_AST.drange in
                  let start_line = FStarC_Range_Ops.line_of_pos start in
                  start_line <= line) decls
     | uu___2 -> decls in
   let qs =
     match parse_result with
     | FStarC_Parser_ParseIt.IncrementalFragment (decls, uu___2, err_opt) ->
         ((let uu___4 =
             FStarC_Class_Show.show FStarC_Class_Show.showable_nat
               (FStarC_List.length decls) in
           FStarC_Format.print1 "Parsed %s declarations\n" uu___4);
          (match (request_type, decls) with
           | (FStarC_Interactive_Ide_Types.ReloadDeps, d::uu___4) ->
               let uu___5 =
                 let uu___6 =
                   let uu___7 =
                     FStarC_Effect.op_Bang
                       FStarC_Interactive_PushHelper.repl_stack in
                   reload_deps uu___7 in
                 op_let_Bang uu___6
                   (fun queries ->
                      let uu___7 =
                        push_decl FStarC_Interactive_Ide_Types.FullCheck
                          with_symbols write_full_buffer_fragment_progress d in
                      op_let_Bang uu___7
                        (fun push_mod ->
                           return ((FStarC_List.op_At queries push_mod), []))) in
               run_qst uu___5 qid1 st
           | uu___4 ->
               let decls1 = filter_decls decls in
               let push_kind =
                 match request_type with
                 | FStarC_Interactive_Ide_Types.LaxToPosition uu___5 ->
                     FStarC_Interactive_Ide_Types.LaxCheck
                 | FStarC_Interactive_Ide_Types.Lax ->
                     FStarC_Interactive_Ide_Types.LaxCheck
                 | uu___5 -> FStarC_Interactive_Ide_Types.FullCheck in
               let uu___5 =
                 let uu___6 =
                   let uu___7 =
                     FStarC_Effect.op_Bang
                       FStarC_Interactive_PushHelper.repl_stack in
                   inspect_repl_stack uu___7 decls1 push_kind with_symbols
                     write_full_buffer_fragment_progress in
                 run_qst uu___6 qid1 st in
               (match uu___5 with
                | (queries, issues) ->
                    (if request_type <> FStarC_Interactive_Ide_Types.Cache
                     then log_syntax_issues err_opt
                     else ();
                     (let uu___8 = FStarC_Effect.op_Bang dbg in
                      if uu___8
                      then
                        let uu___9 =
                          let uu___10 =
                            FStarC_List.map
                              FStarC_Interactive_Ide_Types.query_to_string
                              queries in
                          FStarC_String.concat "\n" uu___10 in
                        FStarC_Format.print1 "Generating queries\n%s\n"
                          uu___9
                      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___2 -> FStarC_Effect.failwith "Unexpected parse result" in
   qs)
let format_code (st : FStarC_Interactive_Ide_Types.repl_state)
  (code : Prims.string) :
  (Prims.string, FStarC_Errors.issue Prims.list) FStar_Pervasives.either=
  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 st 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_Util.float_of_string "1.0")
          (Prims.of_int 100) doc in
      let uu___ =
        FStarC_List.fold_left
          (fun uu___1 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) ->
                      (((doc_to_string doc) :: out), comments2)))
          ([], (FStarC_List.rev comments)) decls in
      (match uu___ with
       | (formatted_code_rev, leftover_comments) ->
           let code1 =
             FStarC_String.concat "\n\n" (FStarC_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
                 Prims.strcat code1 (Prims.strcat "\n\n" (doc_to_string doc)) 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___ -> FStarC_Effect.failwith "Unexpected parse result"
