Source file completion.ml

module AcgEnv = AcgData.Environment.Environment

let completion_suffixes = [ [ Parser.COMPL_ARG_NAME ; Parser.INF ; Parser.DATA "" ]
                          ; [ Parser.COMPL_ARG_NAME ]
                          ; [ Parser.COMPL_ARG_VAL ]
                          ; [ Parser.COMPL_ARG_VAL ; Parser.INF; Parser.DATA "" ]
                          ; [ Parser.COMPL_FUN ]
                          ; [ Parser.COMPL_FUN ; Parser.INF ; Parser.DATA "" ]
                          ; [ Parser.COMPL_LET ] ]

let tok_to_string tok =
  match tok with
  | Parser.SEMI -> "semi"
  | Parser.PIPE -> "pipe"
  | Parser.LET -> "let"
  | Parser.INF -> "inf"
  | Parser.EQUAL -> "equal"
  | Parser.COMMA -> "comma"
  | Parser.PLUS -> "plus"
  | Parser.MINUS -> "minus"
  | Parser.EOI -> "EOI"
  | Parser.COMPL_LET -> "compl_let"
  | Parser.COMPL_FUN -> "compl_fun"
  | Parser.COMPL_ARG_NAME -> "compl_arg_name"
  | Parser.COMPL_ARG_VAL -> "compl_arg_val"
  | Parser.COLON_EQUAL -> "colon_equal"
  | Parser.INT i -> Printf.sprintf "int %i" i
  | Parser.ID id -> Printf.sprintf "id %s" id
  | Parser.DATA s -> Printf.sprintf "data %s" s

let completion_loop checkpoint lexbuf c_pos =
  let rec completion_loop_rec checkpoint lexbuf c_pos =
    match checkpoint with
    | TableParser.MenhirInterpreter.InputNeeded _ -> (
      let tok = Lexer.lex lexbuf in
      let pstart, pend = Sedlexing.lexing_positions lexbuf in
        if pend.Lexing.pos_cnum = c_pos then
          match tok with
          | Lexer.Token (Parser.EOI, _) -> Some ("", checkpoint)
          | Lexer.Token (Parser.LET, _) -> Some ("let", checkpoint)
          | Lexer.Token (Parser.ID id, _) -> Some (id, checkpoint)
          | Lexer.Token (Parser.INT i, _) -> Some (string_of_int i, checkpoint)
          | Lexer.PartialToken (s, _) -> Some (s, checkpoint)
          | Lexer.Token (tok, _) ->
            let new_checkpoint =
              TableParser.MenhirInterpreter.offer checkpoint (tok, pstart, pend)
            in
              Some ("", new_checkpoint)
        else
          match tok with
          | Lexer.Token (tok, _) ->
            let new_checkpoint =
              TableParser.MenhirInterpreter.offer checkpoint (tok, pstart, pend)
            in
              completion_loop_rec new_checkpoint lexbuf c_pos
          | _ -> None)
    | TableParser.MenhirInterpreter.Shifting _
    | TableParser.MenhirInterpreter.AboutToReduce _ ->
      let new_checkpoint = TableParser.MenhirInterpreter.resume checkpoint in
        completion_loop_rec new_checkpoint lexbuf c_pos
    | TableParser.MenhirInterpreter.HandlingError _
    | TableParser.MenhirInterpreter.Rejected
    | TableParser.MenhirInterpreter.Accepted _ -> None in
  try completion_loop_rec checkpoint lexbuf c_pos with _ -> None

let completion_loop_2 checkpoint compl_list pos env =
  let rec completion_loop_2_rec checkpoint compl_list (pstart, pend) =
    match checkpoint with
    | TableParser.MenhirInterpreter.InputNeeded _ ->
      let compl_tok, new_compl_list = match compl_list with
        | tok :: l -> tok, l
        | [] -> Parser.EOI, [] in
      let () = Logs.debug (fun m -> m "token : %s" (tok_to_string compl_tok)) in
      let new_checkpoint =
        TableParser.MenhirInterpreter.offer checkpoint (compl_tok, pstart, pend)
      in
        completion_loop_2_rec new_checkpoint new_compl_list (pend, pend)
    | TableParser.MenhirInterpreter.Shifting _
    | TableParser.MenhirInterpreter.AboutToReduce _ ->
        let new_checkpoint = TableParser.MenhirInterpreter.resume checkpoint in
        completion_loop_2_rec new_checkpoint compl_list (pstart, pend)
    | TableParser.MenhirInterpreter.HandlingError _
    | TableParser.MenhirInterpreter.Rejected ->
      let () = Logs.debug (fun m -> m "Rejected") in ()
    | TableParser.MenhirInterpreter.Accepted res ->
      let () = Logs.debug (fun m -> m "Accepted") in
      let _ = res env in ()
  in
  let () = Logs.debug (fun m -> m "------- compl ---------") in
  try completion_loop_2_rec checkpoint compl_list pos; None with
  | Environment.Completion completion ->
    let () = Logs.debug (fun m -> m "Completion") in
    Some completion
  | _ -> None

let complete env cont_input input =
  let compl_input = cont_input ^ input in
  let lexbuf = Sedlexing.Utf8.from_string (compl_input) in
  let start =
    TableParser.Incremental.interactive_command
      (fst (Sedlexing.lexing_positions lexbuf)) in
  match completion_loop start lexbuf (String.length compl_input) with
  | None -> Readline.Custom []
  | Some (compl_text, compl_checkpoint) ->
    let pos = Sedlexing.lexing_positions lexbuf in
    let compl_list = List.fold_left
      (fun res compl_list ->
        match completion_loop_2 compl_checkpoint compl_list pos env with
        | Some completion -> List.rev_append res (Environment.gen_completions completion compl_text env)
        | _ -> res)
      [] completion_suffixes in
    let filtred_list =
      List.filter
        (fun e ->
          match e with
          | Environment.Ce_String (_compl, compl_comp, _compl_suff) -> String.starts_with ~prefix:compl_text compl_comp
          | Environment.Ce_Path -> true)
        compl_list in
    if List.length compl_list > 0 && List.for_all ((=) Environment.Ce_Path) filtred_list
      then Readline.Filenames
      else Readline.Custom (List.filter_map
        (fun s ->
          match s with
          | Environment.Ce_String (compl, _compl_comp, compl_suff) -> Some (compl, compl_suff)
          | Environment.Ce_Path -> None)
        filtred_list)