hphp/hack/src/server/serverFileSync.ml

   1 (*
   2  * Copyright (c) 2016, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the MIT license found in the
   6  * LICENSE file in the "hack" directory of this source tree.
   7  *
   8  *)
   9
  10 open Core_kernel
  11 open File_content
  12 open Option.Monad_infix
  13 open ServerEnv
  14
  15 let try_relativize_path x =
  16   Option.try_with (fun () -> Relative_path.(create Root x))
  17
  18 let get_file_content_from_disk path =
  19   let f () = Sys_utils.cat (Relative_path.to_absolute path) in
  20   Option.try_with f
  21
  22 let get_file_content = function
  23   | ServerCommandTypes.FileContent s -> s
  24   | ServerCommandTypes.FileName path ->
  25     try_relativize_path path
  26     >>= (fun path ->
  27           match File_provider.get path with
  28           | Some (File_provider.Ide f) -> Some f
  29           | Some (File_provider.Disk c) -> Some c
  30           | None -> get_file_content_from_disk path)
  31     (* In case of errors, proceed with empty file contents *)
  32     |> Option.value ~default:""
  33
  34 (* Warning: this takes O(global error list) time. Should be OK while
  35  * it's only used in editor, where opening a file is a rare (compared to other
  36  * kind of queries) operation, but if this ever ends up being called by
  37  * other automation there is room for improvement (i.e finally changing global
  38  * error list to be a error map)
  39  *)
  40 let update_diagnostics diag_subscribe editor_open_files errorl =
  41   Option.map diag_subscribe ~f:(fun diag_subscribe ->
  42       Diagnostic_subscription.update
  43         diag_subscribe
  44         ~priority_files:editor_open_files
  45         ~reparsed:Relative_path.Set.empty
  46         ~rechecked:Relative_path.Set.empty
  47         ~global_errors:errorl
  48         ~full_check_done:true)
  49
  50 let open_file ~predeclare env path content =
  51   let prev_content = get_file_content (ServerCommandTypes.FileName path) in
  52   let full_path = path in
  53   let new_env =
  54     try_relativize_path path >>= fun path ->
  55     (* Before making any changes, pre-load (into Decl_heap) currently existing
  56      * declarations so there is always a previous version to compare against,
  57      * which makes incremental mode perform better. *)
  58     ( if predeclare && not (Relative_path.Set.mem env.editor_open_files path)
  59     then
  60       let ctx = Provider_utils.ctx_from_server_env env in
  61       Decl.make_env ctx path );
  62     let editor_open_files = Relative_path.Set.add env.editor_open_files path in
  63     File_provider.remove_batch (Relative_path.Set.singleton path);
  64     File_provider.provide_file path (File_provider.Ide content);
  65     let (ide_needs_parsing, diag_subscribe) =
  66       if content = prev_content && env.full_check = Full_check_done then
  67         (* Try to avoid telling the user that a check is needed when the file
  68          * was unchanged. But even in this case, we might need to push
  69          * errors that were previously throttled. They are available only
  70          * when full recheck was completed and there were no further changes. In
  71          * all other cases, we will need to (lazily) recheck the file. *)
  72         let diag_subscribe =
  73           update_diagnostics env.diag_subscribe editor_open_files env.errorl
  74         in
  75         let () =
  76           match (env.diag_subscribe, diag_subscribe) with
  77           | (None, None) ->
  78             Hh_logger.log "Diag_subscribe: open, none before or after"
  79           | (None, Some _) -> Hh_logger.log "Diag_subscribe: open, now active"
  80           | (Some _, Some _) ->
  81             Hh_logger.log "Diag_subscribe: open, remains active"
  82           | (Some _, None) ->
  83             Hh_logger.log "Diag_subscribe: open, REMOVED - %s" full_path
  84         in
  85         (env.ide_needs_parsing, diag_subscribe)
  86       else
  87         let () = Hh_logger.log "open_file; diag_subscribe remains as it was" in
  88         (Relative_path.Set.add env.ide_needs_parsing path, env.diag_subscribe)
  89     in
  90     (* Need to re-parse this file during next full check to update
  91      * global error list positions that refer to it *)
  92     let disk_needs_parsing =
  93       Relative_path.Set.add env.disk_needs_parsing path
  94     in
  95     let last_command_time = Unix.gettimeofday () in
  96     Some
  97       {
  98         env with
  99         editor_open_files;
 100         ide_needs_parsing;
 101         last_command_time;
 102         diag_subscribe;
 103         disk_needs_parsing;
 104       }
 105   in
 106   Option.value new_env ~default:env
 107
 108 let close_relative_path env path =
 109   let editor_open_files = Relative_path.Set.remove env.editor_open_files path in
 110   let contents =
 111     match File_provider.get_unsafe path with
 112     | File_provider.Ide f -> f
 113     | _ -> assert false
 114   in
 115   File_provider.remove_batch (Relative_path.Set.singleton path);
 116   let new_contents = File_provider.get_contents path in
 117   let ide_needs_parsing =
 118     if new_contents = Some contents then
 119       env.ide_needs_parsing
 120     else
 121       Relative_path.Set.add env.ide_needs_parsing path
 122   in
 123   let disk_needs_parsing = Relative_path.Set.add env.disk_needs_parsing path in
 124   let last_command_time = Unix.gettimeofday () in
 125   {
 126     env with
 127     editor_open_files;
 128     ide_needs_parsing;
 129     last_command_time;
 130     disk_needs_parsing;
 131   }
 132
 133 let close_file env path =
 134   let new_env = try_relativize_path path >>| close_relative_path env in
 135   Option.value new_env ~default:env
 136
 137 let edit_file ~predeclare env path (edits : File_content.text_edit list) =
 138   let new_env =
 139     try_relativize_path path >>= fun path ->
 140     (* See similar predeclare in open_file function *)
 141     ( if predeclare && not (Relative_path.Set.mem env.editor_open_files path)
 142     then
 143       let ctx = Provider_utils.ctx_from_server_env env in
 144       Decl.make_env ctx path );
 145     ServerBusyStatus.send env ServerCommandTypes.Needs_local_typecheck;
 146     let fc =
 147       match File_provider.get path with
 148       | Some (File_provider.Ide f) -> f
 149       | Some (File_provider.Disk content) -> content
 150       | None ->
 151         (try Sys_utils.cat (Relative_path.to_absolute path) with _ -> "")
 152     in
 153     let edited_fc =
 154       match edit_file fc edits with
 155       | Ok r -> r
 156       | Error (reason, _stack) ->
 157         Hh_logger.log "%s" reason;
 158
 159         (* TODO: do not crash, but surface this to the client somehow *)
 160         assert false
 161     in
 162     let editor_open_files = Relative_path.Set.add env.editor_open_files path in
 163     File_provider.remove_batch (Relative_path.Set.singleton path);
 164     File_provider.provide_file path (File_provider.Ide edited_fc);
 165     let ide_needs_parsing = Relative_path.Set.add env.ide_needs_parsing path in
 166     let disk_needs_parsing =
 167       Relative_path.Set.add env.disk_needs_parsing path
 168     in
 169     let last_command_time = Unix.gettimeofday () in
 170     Some
 171       {
 172         env with
 173         editor_open_files;
 174         ide_needs_parsing;
 175         last_command_time;
 176         disk_needs_parsing;
 177       }
 178   in
 179   Option.value new_env ~default:env
 180
 181 let clear_sync_data env =
 182   let env =
 183     Relative_path.Set.fold env.editor_open_files ~init:env ~f:(fun x env ->
 184         close_relative_path env x)
 185   in
 186   { env with persistent_client = None; diag_subscribe = None }
 187
 188 let get_unsaved_changes env =
 189   Relative_path.Set.fold
 190     env.editor_open_files
 191     ~init:Relative_path.Map.empty
 192     ~f:(fun path acc ->
 193       match File_provider.get path with
 194       | Some (File_provider.Ide ide_contents) ->
 195         begin
 196           match get_file_content_from_disk path with
 197           | Some disk_contents when ide_contents <> disk_contents ->
 198             Relative_path.Map.add acc path (ide_contents, disk_contents)
 199           | Some _ -> acc
 200           | None ->
 201             (* If one creates a new file, then there will not be corresponding
 202           * disk contents, and we should consider there to be unsaved changes in
 203           * the editor. *)
 204             Relative_path.Map.add acc path (ide_contents, "")
 205         end
 206       | _ -> acc)
 207
 208 let has_unsaved_changes env =
 209   not @@ Relative_path.Map.is_empty (get_unsaved_changes env)
 210
 211 let toggle_dynamic_view (env : env) (t : bool) : env =
 212   ServerDynamicView.toggle := t;
 213   { env with ide_needs_parsing = env.editor_open_files }