123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326 |
- open Ast
- open Common
- open DisplayTypes
- open DisplayMode
- open CompletionItem
- open Type
- open Typecore
- open Globals
- open DisplayPosition
- open ImportStatus
- let merge_core_doc ctx mtype =
- display_position#run_outside (fun () -> Typecore.merge_core_doc ctx mtype)
- let parse_module' com m p =
- display_position#run_outside (fun () -> TypeloadParse.parse_module' com m p)
- let parse_module ctx m p =
- display_position#run_outside (fun () -> TypeloadParse.parse_module ctx m p)
- module ReferencePosition = struct
- let reference_position = ref ("",null_pos,SKOther)
- let set (s,p,k) =
- let p =
- if p = null_pos then p
- else {p with pfile = Path.get_full_path p.pfile}
- in
- reference_position := (s,p,k)
- let get () = !reference_position
- let reset () = reference_position := ("",null_pos,SKOther)
- end
- module ExprPreprocessing = struct
- let find_before_pos dm e =
- let display_pos = ref (DisplayPosition.display_position#get) in
- let was_annotated = ref false in
- let is_annotated,is_completion = match dm with
- | DMDefault -> (fun p -> not !was_annotated && encloses_position !display_pos p),true
- | DMHover -> (fun p -> not !was_annotated && encloses_position_gt !display_pos p),false
- | _ -> (fun p -> not !was_annotated && encloses_position !display_pos p),false
- in
- let annotate e dk =
- was_annotated := true;
- (EDisplay(e,dk),pos e)
- in
- let annotate_marked e = annotate e DKMarked in
- let mk_null p = annotate_marked ((EConst(Ident "null")),p) in
- let loop_el el =
- let pr = DisplayPosition.display_position#with_pos (pos e) in
- let rec loop el = match el with
- | [] -> [mk_null pr]
- | e :: el ->
- if (pos e).pmin >= pr.pmax then (mk_null pr) :: e :: el
- else e :: loop el
- in
- (* print_endline (Printf.sprintf "%i-%i: PR" pr.pmin pr.pmax);
- List.iter (fun e ->
- print_endline (Printf.sprintf "%i-%i: %s" (pos e).pmin (pos e).pmax (Ast.s_expr e));
- ) el; *)
- match el with
- | [] -> [mk_null pr]
- | e :: el ->
- if (pos e).pmin >= pr.pmax then (mk_null pr) :: e :: el
- else loop (e :: el)
- in
- let in_pattern = ref false in
- let loop e =
- (* print_endline (Printf.sprintf "%i-%i: %s" (pos e).pmin (pos e).pmax (Ast.s_expr e)); *)
- match fst e with
- | EFunction(FKNamed((_,p),_),_) when is_annotated p && is_completion ->
- raise Exit
- | EVars vl when is_annotated (pos e) && is_completion ->
- let rec loop2 acc mark vl = match vl with
- | v :: vl ->
- if mark then
- loop2 (v :: acc) mark vl
- else if is_annotated (snd v.ev_name) then
- (* If the name is the display position, mark the expression *)
- loop2 (v :: acc) true vl
- else begin match v.ev_expr with
- | None ->
- (* If there is no expression, we don't have to do anything.
- Should the display position be on the type-hint, it will
- be picked up while loading the type. *)
- loop2 (v :: acc) mark vl
- | Some e ->
- (* Determine the area between the `|` in `var x| = | e`. This is not really
- correct because we don't want completion on the left side of the `=`, but
- we cannot determine that correctly without knowing its position.
- Note: We know `e` itself isn't the display position because this entire
- algorithm is bottom-up and it would be marked already if it was. *)
- let p0 = match v.ev_type with
- | Some (_,pt) -> pt
- | None -> snd v.ev_name
- in
- let p = {p0 with pmax = (pos e).pmin} in
- let e = if is_annotated p then annotate_marked e else e in
- loop2 ({ v with ev_expr = Some e } :: acc) mark vl
- end
- | [] ->
- List.rev acc,mark
- in
- let vl,mark = loop2 [] false vl in
- let e = EVars (List.rev vl),pos e in
- if !was_annotated then e else raise Exit
- | EBinop((OpAssign | OpAssignOp _) as op,e1,e2) when is_annotated (pos e) && is_completion ->
- (* Special case for assign ops: If the expression is marked, but none of its operands are,
- we are "probably" interested in the rhs. Like with EVars, this isn't accurate because we
- could be on the left side of the `=`. I don't think there's a reason for requesting
- completion there though. *)
- (EBinop(op,e1,annotate_marked e2)),(pos e)
- | EBinop(OpOr,e1,(EIf(_,(EConst(Ident "null"),_),None),p1)) when is_annotated (pos e) && is_completion && !in_pattern ->
- (* This HAS TO come from an attempted `case pattern | guard:` completion (issue #7068). *)
- let p = { p1 with pmin = (pos e1).pmax; pmax = p1.pmin } in
- EBinop(OpOr,e1,mk_null p),(pos e)
- | EIf(_,(EConst(Ident "null"),_),None) when is_completion && !in_pattern ->
- (* This is fine. *)
- mk_null (pos e)
- | EBlock [] when is_annotated (pos e) ->
- annotate e DKStructure
- | EBlock [EDisplay((EConst(Ident s),pn),DKMarked),_] when is_completion ->
- let e = EObjectDecl [(s,pn,NoQuotes),(EConst (Ident "null"),null_pos)],(pos e) in
- annotate e DKStructure
- | EBlock el when is_annotated (pos e) && is_completion ->
- let el = loop_el el in
- EBlock el,(pos e)
- | ECall(e1,el) when is_annotated (pos e) && is_completion ->
- let el = loop_el el in
- ECall(e1,el),(pos e)
- | ENew((tp,pp),el) when is_annotated (pos e) && is_completion ->
- if is_annotated pp || pp.pmax >= (DisplayPosition.display_position#get).pmax then
- annotate_marked e
- else begin
- let el = loop_el el in
- ENew((tp,pp),el),(pos e)
- end
- | EArrayDecl el when is_annotated (pos e) && is_completion ->
- let el = loop_el el in
- EArrayDecl el,(pos e)
- | EObjectDecl fl when is_annotated (pos e) && is_completion ->
- annotate e DKStructure
- | ESwitch(e1,cases,def) when is_annotated (pos e) ->
- (* We must be "between" two cases, or at the end of the last case.
- Let's find the last case which has a position that is < the display
- position and mark it. *)
- let did_mark = ref false in
- let mark_case ec p =
- did_mark := true;
- let ep = mk_null p in
- match ec with
- | Some ec ->
- let ec = match fst ec with
- | EBlock el -> (EBlock (el @ [ep]),p)
- | _ -> (EBlock [ec;ep],p)
- in
- Some ec
- | None ->
- Some (mk_null p)
- in
- let rec loop cases = match cases with
- | [el,eg,ec,p1] ->
- let ec = match def with
- | None when (pos e).pmax > !display_pos.pmin -> (* this is so we don't trigger if we're on the } *)
- mark_case ec p1 (* no default, must be the last case *)
- | Some (_,p2) when p1.pmax <= !display_pos.pmin && p2.pmin >= !display_pos.pmax ->
- mark_case ec p1 (* default is beyond display position, mark *)
- | _ ->
- ec (* default contains display position, don't mark *)
- in
- [el,eg,ec,p1]
- | (el1,eg1,ec1,p1) :: (el2,eg2,ec2,p2) :: cases ->
- if p1.pmax <= !display_pos.pmin && p2.pmin >= !display_pos.pmax then
- (el1,eg1,mark_case ec1 p1,p1) :: (el2,eg2,ec2,p2) :: cases
- else
- (el1,eg1,ec1,p1) :: loop ((el2,eg2,ec2,p2) :: cases)
- | [] ->
- []
- in
- let cases = loop cases in
- let def = if !did_mark then
- def
- else match def with
- | Some(eo,p) when (pos e).pmax > !display_pos.pmin -> Some (mark_case eo p,p)
- | _ -> def
- in
- ESwitch(e1,cases,def),pos e
- | EDisplay _ ->
- raise Exit
- | EMeta((Meta.Markup,_,_),(EConst(String _),p)) when is_annotated p ->
- annotate_marked e
- | EConst (String (_,q)) when ((q <> SSingleQuotes) || !Parser.was_auto_triggered) && is_annotated (pos e) && is_completion ->
- (* TODO: check if this makes any sense *)
- raise Exit
- | EConst(Regexp _) when is_annotated (pos e) && is_completion ->
- raise Exit
- | EVars vl when is_annotated (pos e) ->
- (* We only want to mark EVars if we're on a var name. *)
- if List.exists (fun v -> is_annotated (snd v.ev_name)) vl then
- annotate_marked e
- else
- raise Exit
- | _ ->
- if is_annotated (pos e) then
- annotate_marked e
- else
- e
- in
- let opt f o =
- match o with None -> None | Some v -> Some (f v)
- in
- let rec map e = match fst e with
- | ESwitch(e1,cases,def) when is_annotated (pos e) ->
- let e1 = map e1 in
- let cases = List.map (fun (el,eg,e,p) ->
- let old = !in_pattern in
- in_pattern := true;
- let el = List.map map el in
- in_pattern := old;
- let eg = opt map eg in
- let e = opt map e in
- el,eg,e,p
- ) cases in
- let def = opt (fun (eo,p) -> opt map eo,p) def in
- loop (ESwitch (e1, cases, def),(pos e))
- | _ ->
- loop (Ast.map_expr map e)
- in
- try map e with Exit -> e
- let find_display_call e =
- let found = ref false in
- let handle_el e el =
- let call_arg_is_marked () =
- el = [] || List.exists (fun (e,_) -> match e with EDisplay(_,DKMarked) -> true | _ -> false) el
- in
- if not !Parser.was_auto_triggered || call_arg_is_marked () then begin
- found := true;
- Parser.mk_display_expr e DKCall
- end else
- e
- in
- let loop e = match fst e with
- | ECall(_,el) | ENew(_,el) when not !found && display_position#enclosed_in (pos e) ->
- handle_el e el
- | EArray(e1,e2) when not !found && display_position#enclosed_in (pos e2) ->
- handle_el e [e2]
- | EDisplay(_,DKCall) ->
- raise Exit
- | _ -> e
- in
- let rec map e = loop (Ast.map_expr map e) in
- try map e with Exit -> e
- let process_expr com e = match com.display.dms_kind with
- | DMDefinition | DMTypeDefinition | DMUsage _ | DMImplementation | DMHover | DMDefault -> find_before_pos com.display.dms_kind e
- | DMSignature -> find_display_call e
- | _ -> e
- end
- let get_expected_name with_type = match with_type with
- | WithType.Value (Some src) | WithType.WithType(_,Some src) ->
- (match src with
- | WithType.FunctionArgument si -> Some si.si_name
- | WithType.StructureField si -> Some si .si_name
- | WithType.ImplicitReturn -> None
- )
- | _ -> None
- let sort_fields l with_type tk =
- let p = match tk with
- | TKExpr p | TKField p -> Some p
- | _ -> None
- in
- let expected_name = get_expected_name with_type in
- let l = List.map (fun ci ->
- let i = get_sort_index tk ci (Option.default Globals.null_pos p) expected_name in
- ci,i
- ) l in
- let sort l =
- List.map fst (List.sort (fun (_,i1) (_,i2) -> compare i1 i2) l)
- in
- (* This isn't technically accurate, but I don't think it matters. *)
- let rec dynamify_type_params t = match follow t with
- | TInst({cl_kind = KTypeParameter _},_) -> mk_mono()
- | _ -> Type.map dynamify_type_params t
- in
- let l = match with_type with
- | WithType.WithType(t,_) when (match follow t with TMono _ -> false | _ -> true) ->
- let comp item = match item.ci_type with
- | None -> 9
- | Some (t',_) ->
- (* For enum constructors, we consider the return type of the constructor function
- so it has the same priority as argument-less constructors. *)
- let t' = match item.ci_kind,follow t' with
- | ITEnumField _,TFun(_,r) -> r
- | _ -> t'
- in
- let t' = dynamify_type_params t' in
- if type_iseq t' t then 0 (* equal types - perfect *)
- else if t' == t_dynamic then 5 (* dynamic isn't good, but better than incompatible *)
- else try Type.unify t' t; 1 (* assignable - great *)
- with Unify_error _ -> match follow t' with
- | TFun(_,tr) ->
- if type_iseq tr t then 2 (* function returns our exact type - alright *)
- else (try Type.unify tr t; 3 (* function returns compatible type - okay *)
- with Unify_error _ -> 7) (* incompatible function - useless *)
- | _ ->
- 6 (* incompatible type - probably useless *)
- in
- let l = List.map (fun (item,i1) ->
- let i2 = comp item in
- item,(i2,i1)
- ) l in
- sort l
- | _ ->
- sort l
- in
- l
- let get_import_status ctx path =
- try
- let mt' = ctx.g.do_load_type_def ctx null_pos (mk_type_path ([],snd path)) in
- if path <> (t_infos mt').mt_path then Shadowed else Imported
- with _ ->
- Unimported
|