summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Simon Van Casteren <simon.van.casteren@gmail.com>2020-01-04 13:58:50 +0100
committerGravatar Simon Van Casteren <simon.van.casteren@gmail.com>2020-01-04 13:58:50 +0100
commit472f3cf5206a06f0a7eae721f08f0a43276863cf (patch)
tree1f45428250d50bfb47b13776983c561feb563fe1
parent586ebe1d29c591aa735e3ed9b7bfc1b1407b3d69 (diff)
Added some more stuff to lsp getInfo and completions
-rw-r--r--src/getinfo.sml221
-rw-r--r--src/lsp.sml36
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 *)