diff options
Diffstat (limited to 'src/getinfo.sml')
-rw-r--r-- | src/getinfo.sml | 511 |
1 files changed, 207 insertions, 304 deletions
diff --git a/src/getinfo.sml b/src/getinfo.sml index 5a0fe752..f18d0638 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -30,21 +30,19 @@ structure GetInfo :> GET_INFO = struct structure U = ElabUtilPos structure E = ElabEnv structure L = Elab -structure P = Print -fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = +fun isPosIn (file: string) (line: int) (char: int) (span: ErrorMsg.span) = let val start = #first span val end_ = #last span in OS.Path.base file = OS.Path.base (#file span) andalso - (#line start < row orelse - #line start = row andalso #char start <= col) + (#line start < line orelse + #line start = line andalso #char start <= char) andalso - (#line end_ > row orelse - #line end_ = row andalso #char end_ >= col) - + (#line end_ > line orelse + #line end_ = line andalso #char end_ >= char) end fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = @@ -63,8 +61,8 @@ datatype item = | Str of L.str | Decl of L.decl -fun getSpan (f: item * E.env) = - case #1 f of +fun getSpan (f: item) = + case f of Kind k => #2 k | Con c => #2 c | Exp e => #2 e @@ -73,310 +71,215 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d -(* Just use ElabPrint functions. *) -(* These are better for compiler error messages, but it's better than nothing *) -fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] -fun getInfo env str fileName {line = row, character = col} = +fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) + (init: item) + env str fileName {line = line, char = char}: {item: item, env: ElabEnv.env} = let val () = U.mliftConInCon := E.mliftConInCon + val {env: ElabEnv.env, found: Elab.decl option} = + (case str of + L.StrConst decls => + List.foldl (fn (d, acc as {env, found}) => + if #line (#last (#2 d)) < line + then {env = E.declBinds env d, found = found} + else + if #line (#first (#2 d)) <= line andalso line <= #line (#last (#2 d)) + then {env = env, found = SOME d} + else {env = env, found = found}) + {env = env, found = NONE} decls + | _ => { env = env, found = NONE }) + val dummyResult = (init, env) + val result = + case found of + NONE => dummyResult + | SOME d => + U.Decl.foldB + { kind = fn (env, i, acc as (prev, env')) => if f env (Kind i) prev then (Kind i, env) else acc, + con = fn (env, i, acc as (prev, env')) => if f env (Con i) prev then (Con i, env) else acc, + exp = fn (env, i, acc as (prev, env')) => if f env (Exp i) prev then (Exp i, env) else acc, + sgn_item = fn (env, i, acc as (prev, env')) => if f env (Sgn_item i) prev then (Sgn_item i, env) else acc, + sgn = fn (env, i, acc as (prev, env')) => if f env (Sgn i) prev then (Sgn i, env) else acc, + str = fn (env, i, acc as (prev, env')) => if f env (Str i) prev then (Str i, env) else acc, + decl = fn (env, i, acc as (prev, env')) => if f env (Decl i) prev then (Decl i, env) else acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env dummyResult d + in + {item = #1 result, env = #2 result} + end - (* Adding previous declarations in file to environment *) - (* "open <mod>" statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = (case str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) +fun findSmallestSpan env str fileName {line = line, char = char} = + let + fun fitsAndIsSmaller (env: ElabEnv.env) (curr: item) (prev: item) = + isPosIn fileName line char (getSpan curr) andalso isSmallerThan (getSpan curr) (getSpan prev) + val init = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) + in + findInStr fitsAndIsSmaller init env str fileName {line = line, char = char} + end - (* 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 findFirstExpAfter env str fileName {line = line, char = char} = + let + fun currIsAfterPosAndBeforePrev (env: ElabEnv.env) (curr: item) (prev: item) = + (* curr is an exp *) + (case curr of Exp _ => true | _ => false) + andalso + (* curr is after input pos *) + ( line < #line (#first (getSpan curr)) + orelse ( line = #line (#first (getSpan curr)) + andalso char < #char (#first (getSpan curr)))) + andalso + (* curr is before prev *) + (#line (#first (getSpan curr)) < #line (#first (getSpan prev)) + orelse + (#line (#first (getSpan curr)) = #line (#first (getSpan prev)) + andalso #char (#first (getSpan curr)) < #char (#first (getSpan prev)))) + val init = Exp (Elab.EPrim (Prim.Int 0), + { file = fileName + , first = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} }) + in + findInStr currIsAfterPosAndBeforePrev init env str fileName {line = line, char = char} + end - 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 - fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = - P.PD.hvBox (P.PD.PPS.Rel 0, [a, - P.PD.string ": ", - P.PD.break {nsp = 0, offset = 2}, - b]) - - (* 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 *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - let - val rendered = formatTypeBox ( Prim.p_t p - , 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 - formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, span) => - ((let - val found = E.lookupENamed env n - val rendered = formatTypeBox ( P.PD.string (#1 found) - , 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 (formatTypeBox ( P.PD.string varName - , ElabPrint.p_con env domain) - ) - else NONE - | Exp (L.EField (e, c, {field, ...}), loc) => - SOME (formatTypeBox ( P.box [ElabPrint.p_exp env e, - P.PD.string ".", - ElabPrint.p_con env c] - , ElabPrint.p_con env field)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , 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 (formatTypeBox ( P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , 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 (formatTypeBox ( P.PD.string x - , 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 (L.DVal (x, _, con, _), _) => - SOME (formatTypeBox ( P.PD.string x - , 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 => Option.getOpt (Int.maxInt, 99999) - | 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 (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con)) - end - | Decl d => NONE - ) +datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span - , item : item - , env : ElabEnv.env } - , smallestgoodpart : { span : ErrorMsg.span - , desc : P.PD.pp_desc - , env : ElabEnv.env - , item : item - } option - } - ) = - if not (isPosIn fileName row col span) - then - acc - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - 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' - then - (case printGoodPart env item span of - NONE => SOME prev - | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) - else SOME prev - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end +fun getNameOfFoundInEnv (f: foundInEnv) = + case f of + FoundStr (x, _) => x + | FoundCon (x, _) => x + | FoundExp (x, _) => x - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Str (str, { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) - , span = { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} } - , env = env } - } - ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) - , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) +fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + | (Elab.SgiDatatype ds, loc) => + List.concat (List.map (fn (dtx, i, _, cs) => + FoundExp (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => + FoundExp (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + | (Elab.SgiStr (_, name, _, sgn), _) => + [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => + [FoundStr (name, sgn)] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun resolvePrefixes + (env: ElabEnv.env) + (prefixes: string list) + (items : foundInEnv list) + : foundInEnv list + = + case prefixes of + [] => items + | first :: rest => + (case List.find (fn item => getNameOfFoundInEnv item = first) items of + NONE => [] + | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of + (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) + | _ => []) + | SOME (FoundExp (name, c)) => + let + val fields = case ElabOps.reduceCon env c of + (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => + fields + | ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") , l4_) + , ( Elab.CRecord (_, fields) , l3_))) + , l2_) + , _)) + , l1_) => fields + | _ => [] + val items = + List.mapPartial (fn (c1, c2) => case c1 of + (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + | _ => NONE) fields + in + resolvePrefixes env rest items + end + | SOME (FoundCon (_, _)) => []) + + +fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.find (fn i => getNameOfFoundInEnv i = query) afterResolve) + end + +fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * foundInEnv list) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.filter (fn i => String.isPrefix query (getNameOfFoundInEnv i)) afterResolve) + end + +fun getDesc item = + case item of + Kind (_, s) => "Kind " ^ ErrorMsg.spanToString s + | Con (_, s) => "Con " ^ ErrorMsg.spanToString s + | Exp (_, s) => "Exp " ^ ErrorMsg.spanToString s + | Sgn_item (_, s) => "Sgn_item " ^ ErrorMsg.spanToString s + | Sgn (_, s) => "Sgn " ^ ErrorMsg.spanToString s + | Str (_, s) => "Str " ^ ErrorMsg.spanToString s + | Decl (_, s) => "Decl " ^ ErrorMsg.spanToString s + +fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = + let + val {item = _, env} = findSmallestSpan env str fileName pos + val (prefix, matches) = matchStringInEnv' env query + in + (env, prefix, matches) + end + +fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = + let + val {item, env} = findSmallestSpan env str fileName pos + val env = case item of + Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.EAbs _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp e => env + | Con _ => #env (findFirstExpAfter env str fileName pos) + | _ => #env (findFirstExpAfter env str fileName pos) + val preferCon = case item of Con _ => true + | _ => false + val (prefix, found) = findStringInEnv' env preferCon query in - result + (env, prefix, found) end end |