Source file merlin_recovery.ml

let split_pos { Lexing.pos_lnum; pos_bol; pos_cnum; _ } =
  pos_lnum, pos_cnum - pos_bol

let rev_filter ~f xs =
  let rec aux f acc = function
    | x :: xs when f x -> aux f (x :: acc) xs
    | _ :: xs -> aux f acc xs
    | [] -> acc
  in
  aux f [] xs

let rec rev_scan_left acc ~f ~init = function
  | [] -> acc
  | x :: xs ->
    let init = f init x in
    rev_scan_left (init :: acc) ~f ~init xs

module Make
    (Parser : MenhirLib.IncrementalEngine.EVERYTHING)
    (Recovery : sig
       val default_value : Location.t -> 'a Parser.symbol -> 'a

       type action =
         | Abort
         | R of int
         | S : 'a Parser.symbol -> action
         | Sub of action list

       type decision =
         | Nothing
         | One of action list
         | Select of (int -> action list)

       val depth : int array
       val recover : int -> decision
       val guide : 'a Parser.symbol -> bool
       val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token
       val nullable : 'a Parser.nonterminal -> bool
     end) =
struct
  type 'a candidate =
    { line : int
    ; min_col : int
    ; max_col : int
    ; env : 'a Parser.env
    }

  type 'a candidates =
    { shifted : Parser.xsymbol option
    ; final : 'a option
    ; candidates : 'a candidate list
    }

  module T = struct
    [@@@ocaml.warning "-37"]

    type 'a checkpoint =
      | InputNeeded of 'a Parser.env
      | Shifting of 'a Parser.env * 'a Parser.env * bool
      | AboutToReduce of 'a Parser.env * Parser.production
      | HandlingError of 'a Parser.env
      | Accepted of 'a
      | Rejected

    external inj : 'a checkpoint -> 'a Parser.checkpoint = "%identity"
  end

  let feed_token ~allow_reduction token env =
    let rec aux allow_reduction = function
      | Parser.HandlingError _ | Parser.Rejected -> `Fail
      | Parser.AboutToReduce _ when not allow_reduction -> `Fail
      | Parser.Accepted v -> `Accept v
      | (Parser.Shifting _ | Parser.AboutToReduce _) as checkpoint ->
        aux true (Parser.resume checkpoint)
      | Parser.InputNeeded env as checkpoint -> `Recovered (checkpoint, env)
    in
    aux allow_reduction (Parser.offer (T.inj (T.InputNeeded env)) token)

  let rec follow_guide col env =
    match Parser.top env with
    | None -> col
    | Some (Parser.Element (state, _, pos, _)) ->
      if Recovery.guide (Parser.incoming_symbol state)
      then
        match Parser.pop env with
        | None -> col
        | Some env -> follow_guide (snd (split_pos pos)) env
      else col

  let candidate env =
    let line, min_col, max_col =
      match Parser.top env with
      | None -> 1, 0, 0
      | Some (Parser.Element (state, _, pos, _)) ->
        let depth = Recovery.depth.(Parser.number state) in
        let line, col = split_pos pos in
        if depth = 0
        then line, col, col
        else
          let col' =
            match Parser.pop_many depth env with
            | None -> max_int
            | Some env ->
              (match Parser.top env with
              | None -> max_int
              | Some (Parser.Element (_, _, pos, _)) ->
                follow_guide (snd (split_pos pos)) env)
          in
          line, min col col', max col col'
    in
    { line; min_col; max_col; env }

  let attempt r token =
    let _, startp, _ = token in
    let line, col = split_pos startp in
    let more_indented candidate =
      line <> candidate.line && candidate.min_col > col
    in
    let recoveries =
      let rec aux = function
        | x :: xs when more_indented x -> aux xs
        | xs -> xs
      in
      aux r.candidates
    in
    let same_indented candidate =
      line = candidate.line
      || (candidate.min_col <= col && col <= candidate.max_col)
    in
    let recoveries =
      let rec aux = function
        | x :: xs when same_indented x -> x :: aux xs
        | _ -> []
      in
      aux recoveries
    in
    let rec aux = function
      | [] -> `Fail
      | x :: xs ->
        (match feed_token ~allow_reduction:true token x.env with
        | `Fail -> aux xs
        | `Recovered (checkpoint, _) -> `Ok (checkpoint, x.env)
        | `Accept v -> (match aux xs with `Fail -> `Accept v | x -> x))
    in
    aux recoveries

  let decide env =
    let rec nth_state env n =
      if n = 0
      then
        match Parser.top env with
        | None -> -1 (*allow giving up recovery on empty files*)
        | Some (Parser.Element (state, _, _, _)) -> Parser.number state
      else
        match Parser.pop env with
        | None ->
          assert (n = 1);
          -1
        | Some env -> nth_state env (n - 1)
    in
    let st = nth_state env 0 in
    match Recovery.recover st with
    | Recovery.Nothing -> []
    | Recovery.One actions -> actions
    | Recovery.Select f -> f (nth_state env Recovery.depth.(st))

  let generate (type a) (env : a Parser.env) =
    let module E = struct
      exception Result of a
    end
    in
    let shifted = ref None in
    let rec aux acc env =
      match Parser.top env with
      | None -> None, acc
      | Some (Parser.Element (_state, _, _startp, endp)) ->
        let actions = decide env in
        let candidate0 = candidate env in
        let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env
          = function
          | Recovery.Abort -> raise Not_found
          | Recovery.R prod ->
            let prod = Parser.find_production prod in
            Parser.force_reduction prod env
          | Recovery.S (Parser.N n as sym) ->
            let xsym = Parser.X sym in
            if !shifted = None && not (Recovery.nullable n)
            then shifted := Some xsym;
            let loc =
              { Location.loc_start = endp; loc_end = endp; loc_ghost = true }
            in
            let v = Recovery.default_value loc sym in
            Parser.feed sym endp v endp env
          | Recovery.S (Parser.T t as sym) ->
            let xsym = Parser.X sym in
            if !shifted = None then shifted := Some xsym;
            let loc =
              { Location.loc_start = endp; loc_end = endp; loc_ghost = true }
            in
            let v = Recovery.default_value loc sym in
            let token = Recovery.token_of_terminal t v, endp, endp in
            (match feed_token ~allow_reduction:true token env with
            | `Fail -> assert false
            | `Accept v -> raise (E.Result v)
            | `Recovered (_, env) -> env)
          | Recovery.Sub actions -> List.fold_left eval env actions
        in
        (match
           rev_scan_left [] ~f:eval ~init:env actions
           |> List.map (fun env -> { candidate0 with env })
         with
        | exception Not_found -> None, acc
        | exception E.Result v -> Some v, acc
        | [] -> None, acc
        | candidate :: _ as candidates -> aux (candidates @ acc) candidate.env)
    in
    let final, candidates = aux [] env in
    !shifted, final, candidates

  let generate env =
    let shifted, final, candidates = generate env in
    let candidates =
      rev_filter candidates ~f:(fun t ->
        not (Parser.env_has_default_reduction t.env))
    in
    { shifted; final; candidates = candidate env :: candidates }
end