Source file mreader_lexer.ml

(* {{{ COPYING *(

  This file is part of Merlin, an helper for ocaml editors

  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
                             Thomas Refis  <refis.thomas(_)gmail.com>
                             Simon Castellan  <simon.castellan(_)iuwt.fr>

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation the
  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  sell copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  The Software is provided "as is", without warranty of any kind, express or
  implied, including but not limited to the warranties of merchantability,
  fitness for a particular purpose and noninfringement. In no event shall
  the authors or copyright holders be liable for any claim, damages or other
  liability, whether in an action of contract, tort or otherwise, arising
  from, out of or in connection with the software or the use or other dealings
  in the Software.

)* }}} *)

open Std

type keywords = Lexer_raw.keywords

type triple = Parser_raw.token * Lexing.position * Lexing.position

type item =
  | Triple of triple
  | Comment of (string * Location.t)
  | Error of Lexer_raw.error * Location.t

type t = {
  keywords: keywords;
  config: Mconfig.t;
  source: Msource.t;
  items: item list;
}

let get_tokens keywords pos text =
  let state = Lexer_raw.make keywords in
  let lexbuf = Lexing.from_string text in
  Lexing.move lexbuf pos;
  let rec aux items = function
    | Lexer_raw.Return (Parser_raw.COMMENT comment) ->
      continue (Comment comment :: items)
    | Lexer_raw.Refill k -> aux items (k ())
    | Lexer_raw.Return t ->
      let triple = (t, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in
      let items = Triple triple :: items in
      if t = Parser_raw.EOF
      then items
      else continue items
    | Lexer_raw.Fail (err, loc) ->
      continue (Error (err, loc) :: items)

  and continue items =
    aux items (Lexer_raw.token state lexbuf)

  in
  function
  | [] ->
    (* First line: skip #! ... *)
    aux [] (Lexer_raw.skip_sharp_bang state lexbuf)
  | items ->
    (* Resume *)
    continue items

let initial_position config =
  { Lexing.
    pos_fname = (Mconfig.filename config);
    pos_lnum = 1;
    pos_bol = 0;
    pos_cnum = 0;
  }

let make warnings keywords config source =
  Msupport.catch_errors warnings (ref []) @@ fun () ->
  let items =
    get_tokens keywords
    (initial_position config)
    (Msource.text source)
    []
  in
  { keywords; items; config; source }

let item_start = function
  | Triple (_,s,_) -> s
  | Comment (_, l) | Error (_, l) ->
    l.Location.loc_start

let item_end = function
  | Triple (_,_,e) -> e
  | Comment (_, l) | Error (_, l) ->
    l.Location.loc_end

let initial_position t =
  initial_position t.config

let rev_filter_map ~f lst =
  let rec aux acc = function
    | [] -> acc
    | x :: xs ->
      let acc =
        match f x with
        | Some x' -> x' :: acc
        | None -> acc
      in
      aux acc xs
  in
  aux [] lst

let tokens t =
  rev_filter_map t.items
    ~f:(function Triple t -> Some t | _ -> None)

let keywords t =
  Lexer_raw.list_keywords t.keywords

let errors t =
  rev_filter_map t.items
    ~f:(function Error (err, loc) -> Some (Lexer_raw.Error (err, loc))
               | _ -> None)

let comments t =
  rev_filter_map t.items
    ~f:(function Comment t -> Some t | _ -> None)

open Parser_raw

let is_operator = function
  | PREFIXOP s
  | LETOP s | ANDOP s
  | INFIXOP0 s | INFIXOP1 s | INFIXOP2 s | INFIXOP3 s | INFIXOP4 s -> Some s
  | BANG -> Some "!"
  | PERCENT -> Some "%"
  | PLUS -> Some "+"        | PLUSDOT -> Some "+."
  | MINUS -> Some "-"       | MINUSDOT -> Some "-."
  | STAR -> Some "*"        | EQUAL -> Some "="
  | LESS -> Some "<"        | GREATER -> Some ">"
  | OR -> Some "or"         | BARBAR -> Some "||"
  | AMPERSAND -> Some "&"   | AMPERAMPER -> Some "&&"
  | COLONEQUAL -> Some ":=" | PLUSEQ -> Some "+="
  | _ -> None

(* [reconstruct_identifier] is impossible to read at the moment, here is a
   pseudo code version of the function:
   (many thanks to Gabriel for this contribution)

        00| let h = parse (focus h) with
        01|   | . { h+1 }
        02|   | _ { h }
        03| in
        04| parse h with
        05| | BOF x=operator       { [x] }
        06| | ¬( x=operator        { [x] }
        07| | ' x=ident            { [] }
        08| | _ {
        09|   let acc, h = parse (h ! tail h) with
        10|     | x=ident !          { [x], h }
        11|     | ( ! x=operator )   { [x], h }
        12|     | ( x=operator ! )   { [x], h - 1 }
        13|     | ( x=operator ) !   { [x], h - 2 }
        14|     | _ { [], h }
        15|   in
        16|   let h = h - 1 in
        17|   let rec head acc = parse (h !) with
        18|     | tl x=ident . ! { head (x :: acc) tl }
        19|     | x=ident . !    { ident :: acc }
        20|     | _              { acc }
        21|   in head acc
        22| }

   Now for the explanations:
     line 0-3:  if we're on a dot, skip it and move to the right

     line 5,6:  if we're on an operator not preceded by an opening parenthesis,
                just return that.

     line 7:    if we're on a type variable, don't return anything.
                reconstruct_identifier is called when locating and getting the
                type of an expression, in both cases there's nothing we can do
                with a type variable.
                See #317

     line 8-22: two step approach:
       - line 9-15:  retrieve the identifier
                     OR retrieve the parenthesized operator and move before the
                        opening parenthesis

       - line 16-21: retrieve the "path" prefix of the identifier/operator we
                     got in the previous step.


   Additionally, the message of commit fc0b152 explains what we consider is an
   identifier:

     «
        Interpreting an OCaml identifier out of context is a bit ambiguous.

        A prefix of the form (UIDENT DOT)* is the module path,
        A UIDENT suffix is either a module name, a module type name (in case the
        whole path is a module path), or a value constructor.
        A LIDENT suffix is either a value name, a type constructor or a module
        type name.
        A LPAREN OPERATOR RPAREN suffix is a value name (and soon, maybe a
        value constructor if beginning by ':' ?!) .

        In the middle, LIDENT DOT (UIDENT DOT)* is projection of the field of a
        record.  In this case, merlin will drop everything up to the first
        UIDENT and complete in the scope of the (UIDENT DOT)* interpreted as a
        module path.
        Soon, the last UIDENT might also be the type of an inline record.
        (Module2.f.Module1.A <- type of the record of the value constructor named A of
        type f, defined in Module1 and aliased in Module2, pfffff).
     »
*)

let reconstruct_identifier_from_tokens tokens pos =
  let rec look_for_component acc = function

    (* Skip 'a and `A *)
    | ((LIDENT _ | UIDENT _), _, _) ::
      ((BACKQUOTE | QUOTE), _, _) :: items ->
      check acc items

    (* UIDENT is a regular a component *)
    | (UIDENT _, _, _) as item :: items ->
      look_for_dot (item :: acc) items

    (* LIDENT always begin a new identifier *)
    | (LIDENT _, _, _) as item :: items ->
      if acc = []
      then look_for_dot [item] items
      else check acc (item :: items)

    (* Reified operators behave like LIDENT *)
    | (RPAREN, _, _) :: (token, _, _ as item) :: (LPAREN, _, _) :: items
      when is_operator token <> None && acc = [] ->
      look_for_dot [item] items

    (* An operator alone is an identifier on its own *)
    | (token, _, _ as item) :: items
      when is_operator token <> None && acc = [] ->
      check [item] items

    (* Otherwise, check current accumulator and scan the rest of the input *)
    | _ :: items ->
      check acc items

    | [] -> raise Not_found

  and look_for_dot acc = function
    | (DOT,_,_) :: items -> look_for_component acc items
    | items -> check acc items

  and check acc items =
    if acc <> [] &&
       (let startp = match acc with
           | (_, startp, _) :: _ -> startp
           | _ -> assert false in
        Lexing.compare_pos startp pos <= 0) &&
       (let endp = match List.last acc with
           | Some ((_, _, endp)) -> endp
           | _ -> assert false in
        Lexing.compare_pos pos endp <= 0)
    then acc
    else match items with
      | [] -> raise Not_found
      | (_, _, endp) :: _ when Lexing.compare_pos endp pos < 0 ->
        raise Not_found
      | _ -> look_for_component [] items

  in
  match look_for_component [] tokens with
  | exception Not_found -> []
  | acc ->
    let fmt (token, loc_start, loc_end) =
      let id =
        match token with
        | UIDENT s | LIDENT s -> s
        | _ -> match is_operator token with
          | Some t -> t
          | None -> assert false
      in
      Location.mkloc id {Location. loc_start; loc_end; loc_ghost = false}
    in
    let before_pos = function
      | (_, s, _) ->
        Lexing.compare_pos s pos <= 0
    in
    List.map ~f:fmt (List.filter ~f:before_pos acc)

let reconstruct_identifier config source pos =
  let rec lex acc lexbuf =
    let token = Lexer_ident.token lexbuf in
    let item = (token, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in
    match token with
    | EOF -> (item :: acc)
    | EOL when Lexing.compare_pos lexbuf.Lexing.lex_curr_p pos > 0 ->
      (item :: acc)
    | EOL -> lex [] lexbuf
    | _ -> lex (item :: acc) lexbuf
  in
  let lexbuf = Lexing.from_string (Msource.text source) in
  Location.init lexbuf (Mconfig.filename config);
  let tokens = lex [] lexbuf in
  reconstruct_identifier_from_tokens tokens pos

let is_uppercase {Location. txt = x; _} =
  x <> "" && Char.is_uppercase x.[0]

let rec drop_lowercase acc = function
  | [x] -> List.rev (x :: acc)
  | x :: xs when not (is_uppercase x) -> drop_lowercase [] xs
  | x :: xs -> drop_lowercase (x :: acc) xs
  | [] -> List.rev acc

let for_completion t pos =
  let no_labels = ref false in
  let check_label = function
    | Triple ((LABEL _ | OPTLABEL _), _, _) -> no_labels := true
    | _ -> ()
  in
  let rec aux acc = function
    (* Cursor is before item: continue *)
    | item :: items when Lexing.compare_pos (item_start item) pos >= 0 ->
      aux (item :: acc) items

    (* Cursor is in the middle of item: stop *)
    | item :: _ when Lexing.compare_pos (item_end item) pos > 0 ->
      check_label item;
      raise Exit

    (* Cursor is at the end *)
    | ((Triple (token, _, loc_end) as item) :: _) as items
      when Lexing.compare_pos pos loc_end = 0 ->
      check_label item;
      begin match token with
        (* Already on identifier, no need to introduce *)
        | UIDENT _ | LIDENT _ -> raise Exit
        | _ -> acc, items
      end

    | items -> acc, items
  in
  let t =
    match aux [] t.items with
    | exception Exit -> t
    | acc, items ->
      {t with items =
                List.rev_append acc (Triple (LIDENT "", pos, pos) :: items)}
  in
  (!no_labels, t)

let identifier_suffix ident =
  match List.last ident with
  | Some x when is_uppercase x -> drop_lowercase [] ident
  | _ -> ident