From 472f3cf5206a06f0a7eae721f08f0a43276863cf Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 4 Jan 2020 13:58:50 +0100 Subject: Added some more stuff to lsp getInfo and completions --- src/getinfo.sml | 221 ++++++++++++++++++++++++++++++++++++++++++++++---------- src/lsp.sml | 36 +++++---- 2 files changed, 203 insertions(+), 54 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index 1d657637..abe3bc61 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -102,6 +102,43 @@ fun getInfo env str fileName {line = row, character = col} = else env) env decls | _ => env) + (* This isn't very precise since we use the span of the parent exp/decl/etc *) + (* to find the "smallest part" *) + fun printPat env (pat: L.pat) = + if isPosIn fileName row col (#2 pat) + then + case #1 pat of + L.PVar (str, c) => SOME (P.box [ P.PD.string str + , P.PD.string " : " + , ElabPrint.p_con env c]) + | L.PCon (_, _, _, SOME p) => printPat env p + | L.PRecord fields => (case List.mapPartial (fn field => printPat env (#2 field)) fields of + [] => NONE + | first :: _ => SOME first) + | _ => NONE + else NONE + + fun isXmlTag env c = + case c of + L.CApp + ((L.CApp + ((L.CApp + (( L.CApp + (( L.CApp + ((L.CNamed n, _) , _) + , _) + , _) + , _) + , _) + , _) + , _) + , _) + , _) => + (case E.lookupCNamed env n of + ("tag", _, _) => true + | _ => false) + | _ => false + (* TODO We lose some really useful information, like eg. inferred parameters, *) (* which we do have in the actual items (L.Decl, L.Exp, etc) *) (* but not when we do a lookup into the Env *) @@ -109,57 +146,164 @@ fun getInfo env str fileName {line = row, character = col} = fun printGoodPart env f span = (case f of Exp (L.EPrim p, _) => - SOME (P.box [Prim.p_t p, - P.PD.string ": ", - P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) + let + val rendered = P.box [Prim.p_t p, + P.PD.string " : ", + P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")] + in + case p of + Prim.String (_, str) => + if Substring.foldl (fn (c, acc) => acc andalso c = #" ") true (Substring.full str) + then NONE + else SOME rendered + | _ => SOME (rendered) + end | Exp (L.ERel n, _) => SOME ((let val found = E.lookupERel env n in P.box [ P.PD.string (#1 found) - , P.PD.string ": " + , P.PD.string " : " , ElabPrint.p_con env (#2 found)] end) handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, _) => - SOME ((let val found = E.lookupENamed env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (L.ENamed n, span) => + ((let + val found = E.lookupENamed env n + val rendered = P.box [ P.PD.string (#1 found) + , P.PD.string " : " + , ElabPrint.p_con env (#2 found) + ] + (* val () = if #1 found = "body" *) + (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) + (* else () *) + in + (* case #2 found of *) + (* (L.TFun ((L.CUnit, _), (c, _)), _) => *) + (* (if isXmlTag env c *) + (* then SOME (P.box [ P.PD.string "<" *) + (* , P.PD.string ( #1 found) *) + (* , P.PD.string ">" *) + (* ]) *) + (* else SOME rendered) *) + (* | _ => *) SOME rendered + end) + handle E.UnboundNamed _ => SOME (P.PD.string ("UNBOUND_NAMED" ^ Int.toString n))) + | Exp (L.EAbs (varName, domain, _, _), _) => + if isPosIn fileName row col (#2 domain) + then + SOME (P.box [ P.PD.string (varName ^ " : ") + , ElabPrint.p_con env domain + ]) + else NONE + | Exp (L.EField (e, c, {field, ...}), loc) => + SOME (P.box [ElabPrint.p_exp env e, + P.PD.string ".", + ElabPrint.p_con env c, + P.PD.string ": ", + ElabPrint.p_con env field]) | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + (let + val (m1name, m1sgn) = E.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((L.StrProj (str, m), loc), sgn)) + ((L.StrVar m1, loc), m1sgn) + ms + val t = case E.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + case (m1name, x) of + (* Stripping these because XML desugaring adds these with small spans and crowd out the stuff you want to see *) + ("Basis", "cdata") => NONE + | ("Top", "txt") => NONE + | ("Basis", "join") => NONE + | ("Basis", "bind") => NONE + | ("Basis", "sql_subset") => NONE + | ("Basis", "sql_subset_all") => NONE + | ("Basis", "sql_query") => NONE + | ("Basis", "sql_query1") => NONE + | ("Basis", "sql_eq") => NONE + | ("Basis", "sql_inner_join") => NONE + (* | ("Basis", "sql_field") => NONE *) + | ("Basis", "sql_binary") => NONE + | _ => + SOME (P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , P.PD.string " : " + , ElabPrint.p_con env t + ]) + end + handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) + | Exp (L.ELet (edecls, _, _), _) => + let + val found = List.mapPartial + (fn (edecl, loc) => + if isPosIn fileName row col loc + then + case edecl of + L.EDVal (pat, _, _) => printPat env pat + | L.EDValRec ((x, c, _) :: _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env c]) + | _ => NONE + else NONE) + edecls + in + if List.length found > 0 + then SOME (List.hd found) + else NONE + end + | Exp (L.ECase (_, pats, _), _) => + (case List.find (fn ((pat', loc), exp) => isPosIn fileName row col loc) pats of + NONE => NONE + | SOME (pat, _) => printPat env pat) | Exp e => NONE | Kind k => NONE | Con c => NONE | Sgn_item si => NONE | Sgn s => NONE | Str s => NONE - | Decl d => NONE) + | Decl (L.DVal (x, _, con, _), _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env con ]) + | Decl (L.DValRec decls, _) => + (* valrecs don't have nice spans per declaration so we find the *) + (* declaration for which the con starts closest *) + let + val res = + List.foldl (fn (decl, accO) => + let + val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) + val accDistanceFromRow = case accO of + NONE => 999 + | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) + in + if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 + then SOME decl + else accO + end) + NONE + decls + in + case res of + NONE => NONE + | SOME (x, _, con, _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env con + ]) + end + | Decl d => NONE + ) fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span , item : item @@ -187,7 +331,8 @@ fun getInfo env str fileName {line = row, character = col} = NONE => NONE | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => - if isSmallerThan span span' + if + isSmallerThan span span' then (case printGoodPart env item span of NONE => SOME prev diff --git a/src/lsp.sml b/src/lsp.sml index 79b96ef9..e00bd850 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -465,23 +465,27 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion (* TODO PERF SMALL: first match and then equal is not perfect *) val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs + val reduced = List.map (fn (name, c) => + (name, ElabOps.reduceCon env c) + handle ex => (name, (Elab.CUnit, ErrorMsg.dummySpan))) + filteredEs in - (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of - [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | (name, (* TODO this doesn't always work. I've only managed to get it working for tables in a different module *) - ( ( Elab.CApp - ( ( (Elab.CApp - ( ( Elab.CModProj (_, _, "sql_table") - , l4_) - , ( Elab.CRecord (_, fields) - , l3_))) - , l2_) - , _)) - , l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | _ => []) + case reduced of + [] => [] + | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | (name, + ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") + , l4_) + , ( Elab.CRecord (_, fields) + , l3_))) + , l2_) + , _)) + , l1_)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | _ => [] end | _ => (* TODO NOTIMPLEMENTED submodules / nested records *) -- cgit v1.2.3