From 80e7bb6165a5ad6517b35f301228f56b58eef39c Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Wed, 31 Jul 2019 15:13:18 +0200 Subject: first iteration of "typeOf" command --- src/compiler.sml | 187 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 187 insertions(+) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 0aba3a40..46a035ee 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1781,4 +1781,191 @@ fun moduleOf fname = end end +fun isPosIn row col span = + let + val start = #first span + val end_ = #last span + in + ((#line start < row) orelse + (#line start = row) andalso (#char start <= col)) + andalso + ((#line end_ > row) orelse + (#line end_ = row) andalso (#char end_ >= col)) + end + +fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = + (#line (#first s1) > #line (#first s2) orelse + (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) + andalso + (#line (#last s1) < #line (#last s2) orelse + (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) + +datatype foundStuff = + Kind of Elab.kind + | Con of Elab.con + | Exp of Elab.exp + | Sgn_item of Elab.sgn_item + | Sgn of Elab.sgn + | Str of Elab.str + | Decl of Elab.decl + +fun getSpan (f: foundStuff * ElabEnv.env) = + case #1 f of + Kind k => #2 k + | Con c => #2 c + | Exp e => #2 e + | Sgn_item si => #2 si + | Sgn s => #2 s + | Str s => #2 s + | Decl d => #2 d + +fun getTypeAt file row col = + if not (!Elaborate.incremental) + then Print.PD.string "ERROR: urweb daemon is needed to use typeOf command" + else + case ModDb.lookupForTooling (moduleOf file) of + NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) + | SOME (decl, deps) => + let + (* TODO Top is not always found as a dep *) + val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon + (* Adding dependencies to environment *) + val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) + ElabEnv.empty + deps + (* Adding previous declarations to environment *) + val env = + case #1 decl of + Elab.DStr (name, _, sgn, str) => + (case #1 str of + Elab.StrConst decls => + List.foldl + (fn (d, e) => ElabEnv.declBinds e d) + env + decls + | _ => env) + | Elab.DFfiStr _ => env + | _ => env + (* Look for item under cursor *) + val (atPosition, env) = + ElabUtilPos.Decl.foldB + { kind = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Kind (k, span), env) + else acc , + con = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Con (k, span), env) + else acc, + exp = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Exp (k, span), env) + else acc, + sgn_item = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Sgn_item (k, span), env) + else acc, + sgn = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Sgn (k, span), env) + else acc, + str = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Str (k, span), env) + else acc, + decl = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Decl (k, span), env) + else acc, + bind = fn (env, binder) => + case binder of + ElabUtilPos.Decl.RelK x => + ElabEnv.pushKRel env x + | ElabUtilPos.Decl.RelC (x, k) => + ElabEnv.pushCRel env x k + | ElabUtilPos.Decl.NamedC (x, n, k, co) => + ElabEnv.pushCNamedAs env x n k co + | ElabUtilPos.Decl.RelE (x, c) => + ElabEnv.pushERel env x c + | ElabUtilPos.Decl.NamedE (x, c) => + #1 (ElabEnv.pushENamed env x c) + | ElabUtilPos.Decl.Str (x, n, sgn) => + #1 (ElabEnv.pushStrNamed env x sgn) + | ElabUtilPos.Decl.Sgn (x, n, sgn) => + #1 (ElabEnv.pushSgnNamed env x sgn) + } + env + (Decl (#1 decl, { file = file + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , env) + decl + in + case atPosition of + Kind k => + Print.box [Print.PD.string "Not implemented yet, KIND: ", ElabPrint.p_kind env k] + | Con c => + Print.box [Print.PD.string "Not implemented yet, CON: ", ElabPrint.p_con env c] + | Exp (Elab.EPrim p, _) => + Print.box [Prim.p_t p, + Print.PD.string ": ", + Print.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")] + | Exp (Elab.ERel n, _) => + ((let val found = ElabEnv.lookupERel env n + in + + Print.box [ Print.PD.string (#1 found) + , Print.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle ElabEnv.UnboundRel _ => Print.PD.string ("UNBOUND_REL" ^ Int.toString n)) + | Exp (Elab.ENamed n, _) => + ((let val found = ElabEnv.lookupENamed env n + in + Print.box [ Print.PD.string (#1 found) + , Print.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle ElabEnv.UnboundNamed _ => Print.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (Elab.EModProj ( m1 (* number (= "name") of top level module *) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + (let + val (m1name, m1sgn) = ElabEnv.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case ElabEnv.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((Elab.StrProj (str, m), loc), sgn)) + ((Elab.StrVar m1, loc), m1sgn) + ms + val t = case ElabEnv.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + Print.box [ Print.p_list_sep (Print.PD.string ".") Print.PD.string (m1name :: ms @ [x]) + , Print.PD.string ": " + , ElabPrint.p_con env t + ] + end + handle ElabEnv.UnboundNamed _ => Print.PD.string ("Module not found: " ^ Int.toString m1)) + | Exp e => Print.box [Print.PD.string "Not implemented yet, EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => Print.box [Print.PD.string "Not implemented yet, SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => Print.box [Print.PD.string "Not implemented yet, SGN: ", ElabPrint.p_sgn env s] + | Str s => Print.box [Print.PD.string "Not implemented yet, STR: ", ElabPrint.p_str env s] + | Decl d => Print.box [Print.PD.string "Not implemented yet, DECL: ", ElabPrint.p_decl env d] + end + + +fun typeOf loc = + case String.tokens (fn ch => ch = #":") loc of + file :: rowStr :: colStr :: nil => + (case (Int.fromString rowStr, Int.fromString colStr) of + (SOME row, SOME col) => + Print.box [getTypeAt file row col, Print.PD.string "\n"] + | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be ") + | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be " end -- cgit v1.2.3 From 9e2b026fea11ae89a53d4fc1c674ef8e43b2c2ce Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Thu, 1 Aug 2019 09:57:46 +0200 Subject: Added file check to typeOf and always add Top and Basis to env in typeOf --- src/compiler.sml | 22 ++++++++++++---------- src/mod_db.sml | 7 ++++++- 2 files changed, 18 insertions(+), 11 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 46a035ee..51cf20e1 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1781,11 +1781,13 @@ fun moduleOf fname = end end -fun isPosIn row col span = +fun isPosIn file row col span = let val start = #first span val end_ = #last span in + (String.isSuffix file (#file span)) + andalso ((#line start < row) orelse (#line start = row) andalso (#char start <= col)) andalso @@ -1827,10 +1829,10 @@ fun getTypeAt file row col = NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) | SOME (decl, deps) => let - (* TODO Top is not always found as a dep *) val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon (* Adding dependencies to environment *) - val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) + val env = List.foldl (fn (d, e) => + ElabEnv.declBinds e d) ElabEnv.empty deps (* Adding previous declarations to environment *) @@ -1850,31 +1852,31 @@ fun getTypeAt file row col = val (atPosition, env) = ElabUtilPos.Decl.foldB { kind = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Kind (k, span), env) else acc , con = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Con (k, span), env) else acc, exp = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Exp (k, span), env) else acc, sgn_item = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Sgn_item (k, span), env) else acc, sgn = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Sgn (k, span), env) else acc, str = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Str (k, span), env) else acc, decl = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Decl (k, span), env) else acc, bind = fn (env, binder) => diff --git a/src/mod_db.sml b/src/mod_db.sml index fdf6d5ab..57d85195 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -214,7 +214,12 @@ fun lookupForTooling name = SOME (#Decl m, List.map (fn a => #Decl a) (List.mapPartial (fn d => SM.find (!byName, d)) - (SS.listItems (#Deps m)))) + (* Clumsy way of adding Basis and Top without adding doubles *) + (["Basis", "Top"] + @ + (List.filter + (fn x => x <> "Basis" andalso x <> "Top") + (SS.listItems (#Deps m)))))) val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) -- cgit v1.2.3 From 0e520d3fd675bcebb5751bd1a0c304033f4f7782 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Thu, 1 Aug 2019 17:38:09 +0200 Subject: Improved typeOf searching and handling of Top and Basis --- src/compiler.sml | 285 ++++++++++++++++++++++++++++++++---------------------- src/elaborate.sig | 6 ++ 2 files changed, 173 insertions(+), 118 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 51cf20e1..7ceb209a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1786,13 +1786,14 @@ fun isPosIn file row col span = val start = #first span val end_ = #last span in - (String.isSuffix file (#file span)) + String.isSuffix file (#file span) andalso - ((#line start < row) orelse - (#line start = row) andalso (#char start <= col)) + (#line start < row orelse + #line start = row andalso #char start <= col) andalso - ((#line end_ > row) orelse - (#line end_ = row) andalso (#char end_ >= col)) + (#line end_ > row orelse + #line end_ = row andalso #char end_ >= col) + end fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = @@ -1827,138 +1828,186 @@ fun getTypeAt file row col = else case ModDb.lookupForTooling (moduleOf file) of NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) - | SOME (decl, deps) => + | SOME (modDecl, deps) => let val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon + (* Adding dependencies to environment *) - val env = List.foldl (fn (d, e) => - ElabEnv.declBinds e d) + val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) ElabEnv.empty deps - (* Adding previous declarations to environment *) + + (* Adding previous declarations in file to environment *) + (* "open " statements are already translated during elaboration *) + (* They get added to the env here ("unprefixed") *) val env = - case #1 decl of + case #1 modDecl of Elab.DStr (name, _, sgn, str) => (case #1 str of Elab.StrConst decls => - List.foldl - (fn (d, e) => ElabEnv.declBinds e d) - env - decls + List.foldl (fn (d, env) => + if #line (#first (#2 d)) <= row + andalso #char (#first (#2 d)) <= col + then ElabEnv.declBinds env d + else env) env decls | _ => env) | Elab.DFfiStr _ => env | _ => env + + (* Basis and Top need to be added to the env explicitly *) + val env = + case ModDb.lookupForTooling "Top" of + NONE => raise Fail "ERROR: Top module not found in ModDb" + | SOME ((Elab.DStr (_, top_n, topSgn, topStr), _), _) => + #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) + | _ => raise Fail "ERROR: Impossible" + + val env = + case ModDb.lookupForTooling "Basis" of + NONE => raise Fail "ERROR: Top module not found in ModDb" + | SOME ((Elab.DFfiStr (_, basis_n, sgn), _), _) => + #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) + | _ => raise Fail "ERROR: Impossible" + + fun printLiterally {span = span, item = item, env = env} = + Print.box [ Print.PD.string "Nothing good found, printing literally: \n" + , Print.PD.cut + , case item of + Kind k => Print.box [Print.PD.string "KIND: ", ElabPrint.p_kind env k] + | Con c => Print.box [Print.PD.string "CON: ", ElabPrint.p_con env c] + | Exp e => Print.box [Print.PD.string "EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => Print.box [Print.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => Print.box [Print.PD.string "SGN: ", ElabPrint.p_sgn env s] + | Str s => Print.box [Print.PD.string "STR: ", ElabPrint.p_str env s] + | Decl d => Print.box [Print.PD.string "DECL: ", ElabPrint.p_decl env d] + , Print.PD.string "\n" + ] + + (* TODO We lose some really useful information, like eg. inferred parameters, *) + (* which we do have in the actual items (Elab.Decl, Elab.Exp, etc) *) + (* but not when we do a lookup into the Env *) + (* TODO Rename *) + fun printGoodPart env f span = + (case f of + Exp (Elab.EPrim p, _) => + SOME (Print.box [Prim.p_t p, + Print.PD.string ": ", + Print.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")]) + | Exp (Elab.ERel n, _) => + SOME ((let val found = ElabEnv.lookupERel env n + in + + Print.box [ Print.PD.string (#1 found) + , Print.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle ElabEnv.UnboundRel _ => Print.PD.string ("UNBOUND_REL" ^ Int.toString n)) + | Exp (Elab.ENamed n, _) => + SOME ((let val found = ElabEnv.lookupENamed env n + in + Print.box [ Print.PD.string (#1 found) + , Print.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle ElabEnv.UnboundNamed _ => Print.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (Elab.EModProj ( m1 (* number (= "name") of top level module *) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + SOME (let + val (m1name, m1sgn) = ElabEnv.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case ElabEnv.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((Elab.StrProj (str, m), loc), sgn)) + ((Elab.StrVar m1, loc), m1sgn) + ms + val t = case ElabEnv.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + Print.box [ Print.p_list_sep (Print.PD.string ".") Print.PD.string (m1name :: ms @ [x]) + , Print.PD.string ": " + , ElabPrint.p_con env t + ] + end + handle ElabEnv.UnboundNamed _ => Print.PD.string ("Module not found: " ^ Int.toString m1)) + | Exp e => NONE + | Kind k => NONE + | Con c => NONE + | Sgn_item si => NONE + | Sgn s => NONE + | Str s => NONE + | Decl d => NONE) + + fun add env item span acc = + if not (isPosIn file 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, span)) + | SOME (desc', span') => + if isSmallerThan span span' + then + (case printGoodPart env item span of + NONE => SOME (desc', span') + | SOME desc => SOME (desc, span)) + else SOME (desc', span') + in + {smallest = smallest, smallestgoodpart = smallestgoodpart} + end + (* Look for item under cursor *) - val (atPosition, env) = + val result = ElabUtilPos.Decl.foldB - { kind = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Kind (k, span), env) - else acc , - con = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Con (k, span), env) - else acc, - exp = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Exp (k, span), env) - else acc, - sgn_item = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Sgn_item (k, span), env) - else acc, - sgn = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Sgn (k, span), env) - else acc, - str = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Str (k, span), env) - else acc, - decl = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Decl (k, span), env) - else acc, + { 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 - ElabUtilPos.Decl.RelK x => - ElabEnv.pushKRel env x - | ElabUtilPos.Decl.RelC (x, k) => - ElabEnv.pushCRel env x k - | ElabUtilPos.Decl.NamedC (x, n, k, co) => - ElabEnv.pushCNamedAs env x n k co - | ElabUtilPos.Decl.RelE (x, c) => - ElabEnv.pushERel env x c - | ElabUtilPos.Decl.NamedE (x, c) => - #1 (ElabEnv.pushENamed env x c) - | ElabUtilPos.Decl.Str (x, n, sgn) => - #1 (ElabEnv.pushStrNamed env x sgn) - | ElabUtilPos.Decl.Sgn (x, n, sgn) => - #1 (ElabEnv.pushSgnNamed env x sgn) + ElabUtilPos.Decl.RelK x => ElabEnv.pushKRel env x + | ElabUtilPos.Decl.RelC (x, k) => ElabEnv.pushCRel env x k + | ElabUtilPos.Decl.NamedC (x, n, k, co) => ElabEnv.pushCNamedAs env x n k co + | ElabUtilPos.Decl.RelE (x, c) => ElabEnv.pushERel env x c + | ElabUtilPos.Decl.NamedE (x, c) => #1 (ElabEnv.pushENamed env x c) + | ElabUtilPos.Decl.Str (x, n, sgn) => #1 (ElabEnv.pushStrNamed env x sgn) + | ElabUtilPos.Decl.Sgn (x, n, sgn) => #1 (ElabEnv.pushSgnNamed env x sgn) } env - (Decl (#1 decl, { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) - , env) - decl + { smallestgoodpart = NONE + , smallest = { item = Decl (#1 modDecl, { file = file + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , span = { file = file + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} } + , env = env } + } + modDecl in - case atPosition of - Kind k => - Print.box [Print.PD.string "Not implemented yet, KIND: ", ElabPrint.p_kind env k] - | Con c => - Print.box [Print.PD.string "Not implemented yet, CON: ", ElabPrint.p_con env c] - | Exp (Elab.EPrim p, _) => - Print.box [Prim.p_t p, - Print.PD.string ": ", - Print.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")] - | Exp (Elab.ERel n, _) => - ((let val found = ElabEnv.lookupERel env n - in - - Print.box [ Print.PD.string (#1 found) - , Print.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle ElabEnv.UnboundRel _ => Print.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (Elab.ENamed n, _) => - ((let val found = ElabEnv.lookupENamed env n - in - Print.box [ Print.PD.string (#1 found) - , Print.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle ElabEnv.UnboundNamed _ => Print.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) - | Exp (Elab.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - (let - val (m1name, m1sgn) = ElabEnv.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case ElabEnv.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((Elab.StrProj (str, m), loc), sgn)) - ((Elab.StrVar m1, loc), m1sgn) - ms - val t = case ElabEnv.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - Print.box [ Print.p_list_sep (Print.PD.string ".") Print.PD.string (m1name :: ms @ [x]) - , Print.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle ElabEnv.UnboundNamed _ => Print.PD.string ("Module not found: " ^ Int.toString m1)) - | Exp e => Print.box [Print.PD.string "Not implemented yet, EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => Print.box [Print.PD.string "Not implemented yet, SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => Print.box [Print.PD.string "Not implemented yet, SGN: ", ElabPrint.p_sgn env s] - | Str s => Print.box [Print.PD.string "Not implemented yet, STR: ", ElabPrint.p_str env s] - | Decl d => Print.box [Print.PD.string "Not implemented yet, DECL: ", ElabPrint.p_decl env d] + case #smallestgoodpart result of + NONE => printLiterally (#smallest result) + | SOME (desc, span) => + Print.box [(* Print.PD.string (ErrorMsg.spanToString span), Print.PD.string " @ " *) + desc + , Print.PD.string "\n"] end diff --git a/src/elaborate.sig b/src/elaborate.sig index d60cff42..03359814 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -47,4 +47,10 @@ signature ELABORATE = sig val incremental : bool ref val verbose : bool ref + val dopen: ElabEnv.env + -> { str: int + , strs: string list + , sgn: Elab.sgn } + -> (Elab.decl list * ElabEnv.env) + end -- cgit v1.2.3 From 120b7d2886e71b6e2000f94f0570d933542b2941 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sat, 3 Aug 2019 08:19:26 +0200 Subject: Removed some unnecessary prints --- src/compiler.sml | 9 ++------- src/main.mlton.sml | 3 +-- 2 files changed, 3 insertions(+), 9 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 7ceb209a..2e6cf312 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1880,7 +1880,6 @@ fun getTypeAt file row col = | Sgn s => Print.box [Print.PD.string "SGN: ", ElabPrint.p_sgn env s] | Str s => Print.box [Print.PD.string "STR: ", ElabPrint.p_str env s] | Decl d => Print.box [Print.PD.string "DECL: ", ElabPrint.p_decl env d] - , Print.PD.string "\n" ] (* TODO We lose some really useful information, like eg. inferred parameters, *) @@ -2004,10 +2003,7 @@ fun getTypeAt file row col = in case #smallestgoodpart result of NONE => printLiterally (#smallest result) - | SOME (desc, span) => - Print.box [(* Print.PD.string (ErrorMsg.spanToString span), Print.PD.string " @ " *) - desc - , Print.PD.string "\n"] + | SOME (desc, span) => desc end @@ -2015,8 +2011,7 @@ fun typeOf loc = case String.tokens (fn ch => ch = #":") loc of file :: rowStr :: colStr :: nil => (case (Int.fromString rowStr, Int.fromString colStr) of - (SOME row, SOME col) => - Print.box [getTypeAt file row col, Print.PD.string "\n"] + (SOME row, SOME col) => getTypeAt file row col | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be ") | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be " end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 8e70e398..bb5d2166 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -441,8 +441,7 @@ val () = (Globals.setResetTime (); wrs = [Socket.sockDesc sock], exs = [], timeout = SOME (Time.fromSeconds 1)}))) then - (TextIO.print "Using daemon\n"; - app (fn arg => send (sock, arg ^ "\n")) args; + (app (fn arg => send (sock, arg ^ "\n")) args; send (sock, "\n"); OS.Process.exit (wait ())) else -- cgit v1.2.3 From a37678c2cf668b4837cdf5d147f4c2f26b2634e9 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sat, 3 Aug 2019 10:37:07 +0200 Subject: Added comments and extracted typeOf/getInfo into seperate module --- src/compiler.sig | 1 - src/compiler.sml | 233 ------------------------------------------- src/elab_util_pos.sig | 3 + src/errormsg.sig | 1 + src/getinfo.sig | 31 ++++++ src/getinfo.sml | 270 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/main.mlton.sml | 8 +- src/mod_db.sig | 3 +- src/mod_db.sml | 38 +++---- src/sources | 3 + 10 files changed, 329 insertions(+), 262 deletions(-) create mode 100644 src/getinfo.sig create mode 100644 src/getinfo.sml (limited to 'src/compiler.sml') diff --git a/src/compiler.sig b/src/compiler.sig index 7f724b0f..6ed2f9a6 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -215,7 +215,6 @@ signature COMPILER = sig val addModuleRoot : string * string -> unit val moduleOf : string -> string - val typeOf : string -> Print.PD.pp_desc val setStop : string -> unit (* Stop compilation after this phase. *) diff --git a/src/compiler.sml b/src/compiler.sml index 2e6cf312..0aba3a40 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1781,237 +1781,4 @@ fun moduleOf fname = end end -fun isPosIn file row col span = - let - val start = #first span - val end_ = #last span - in - String.isSuffix file (#file span) - andalso - (#line start < row orelse - #line start = row andalso #char start <= col) - andalso - (#line end_ > row orelse - #line end_ = row andalso #char end_ >= col) - - end - -fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = - (#line (#first s1) > #line (#first s2) orelse - (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) - andalso - (#line (#last s1) < #line (#last s2) orelse - (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) - -datatype foundStuff = - Kind of Elab.kind - | Con of Elab.con - | Exp of Elab.exp - | Sgn_item of Elab.sgn_item - | Sgn of Elab.sgn - | Str of Elab.str - | Decl of Elab.decl - -fun getSpan (f: foundStuff * ElabEnv.env) = - case #1 f of - Kind k => #2 k - | Con c => #2 c - | Exp e => #2 e - | Sgn_item si => #2 si - | Sgn s => #2 s - | Str s => #2 s - | Decl d => #2 d - -fun getTypeAt file row col = - if not (!Elaborate.incremental) - then Print.PD.string "ERROR: urweb daemon is needed to use typeOf command" - else - case ModDb.lookupForTooling (moduleOf file) of - NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) - | SOME (modDecl, deps) => - let - val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon - - (* Adding dependencies to environment *) - val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) - ElabEnv.empty - deps - - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here ("unprefixed") *) - val env = - case #1 modDecl of - Elab.DStr (name, _, sgn, str) => - (case #1 str of - Elab.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then ElabEnv.declBinds env d - else env) env decls - | _ => env) - | Elab.DFfiStr _ => env - | _ => env - - (* Basis and Top need to be added to the env explicitly *) - val env = - case ModDb.lookupForTooling "Top" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((Elab.DStr (_, top_n, topSgn, topStr), _), _) => - #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) - | _ => raise Fail "ERROR: Impossible" - - val env = - case ModDb.lookupForTooling "Basis" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((Elab.DFfiStr (_, basis_n, sgn), _), _) => - #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) - | _ => raise Fail "ERROR: Impossible" - - fun printLiterally {span = span, item = item, env = env} = - Print.box [ Print.PD.string "Nothing good found, printing literally: \n" - , Print.PD.cut - , case item of - Kind k => Print.box [Print.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => Print.box [Print.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => Print.box [Print.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => Print.box [Print.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => Print.box [Print.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => Print.box [Print.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => Print.box [Print.PD.string "DECL: ", ElabPrint.p_decl env d] - ] - - (* TODO We lose some really useful information, like eg. inferred parameters, *) - (* which we do have in the actual items (Elab.Decl, Elab.Exp, etc) *) - (* but not when we do a lookup into the Env *) - (* TODO Rename *) - fun printGoodPart env f span = - (case f of - Exp (Elab.EPrim p, _) => - SOME (Print.box [Prim.p_t p, - Print.PD.string ": ", - Print.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) - | Exp (Elab.ERel n, _) => - SOME ((let val found = ElabEnv.lookupERel env n - in - - Print.box [ Print.PD.string (#1 found) - , Print.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle ElabEnv.UnboundRel _ => Print.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (Elab.ENamed n, _) => - SOME ((let val found = ElabEnv.lookupENamed env n - in - Print.box [ Print.PD.string (#1 found) - , Print.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle ElabEnv.UnboundNamed _ => Print.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) - | Exp (Elab.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = ElabEnv.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case ElabEnv.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((Elab.StrProj (str, m), loc), sgn)) - ((Elab.StrVar m1, loc), m1sgn) - ms - val t = case ElabEnv.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - Print.box [ Print.p_list_sep (Print.PD.string ".") Print.PD.string (m1name :: ms @ [x]) - , Print.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle ElabEnv.UnboundNamed _ => Print.PD.string ("Module not found: " ^ Int.toString m1)) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl d => NONE) - - fun add env item span acc = - if not (isPosIn file 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, span)) - | SOME (desc', span') => - if isSmallerThan span span' - then - (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end - - (* Look for item under cursor *) - val result = - ElabUtilPos.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 - ElabUtilPos.Decl.RelK x => ElabEnv.pushKRel env x - | ElabUtilPos.Decl.RelC (x, k) => ElabEnv.pushCRel env x k - | ElabUtilPos.Decl.NamedC (x, n, k, co) => ElabEnv.pushCNamedAs env x n k co - | ElabUtilPos.Decl.RelE (x, c) => ElabEnv.pushERel env x c - | ElabUtilPos.Decl.NamedE (x, c) => #1 (ElabEnv.pushENamed env x c) - | ElabUtilPos.Decl.Str (x, n, sgn) => #1 (ElabEnv.pushStrNamed env x sgn) - | ElabUtilPos.Decl.Sgn (x, n, sgn) => #1 (ElabEnv.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Decl (#1 modDecl, { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) - , span = { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} } - , env = env } - } - modDecl - in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc - end - - -fun typeOf loc = - case String.tokens (fn ch => ch = #":") loc of - file :: rowStr :: colStr :: nil => - (case (Int.fromString rowStr, Int.fromString colStr) of - (SOME row, SOME col) => getTypeAt file row col - | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be ") - | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be " end diff --git a/src/elab_util_pos.sig b/src/elab_util_pos.sig index f616f7f3..95d8b591 100644 --- a/src/elab_util_pos.sig +++ b/src/elab_util_pos.sig @@ -25,6 +25,9 @@ * POSSIBILITY OF SUCH DAMAGE. *) +(* This is identical to ELAB_UTIL, but keeps source spans around *) +(* Maybe these modules can be unified? *) + signature ELAB_UTIL_POS = sig val mliftConInCon : (int -> Elab.con -> Elab.con) ref diff --git a/src/errormsg.sig b/src/errormsg.sig index b4a508d9..4cf8b50a 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -48,6 +48,7 @@ signature ERROR_MSG = sig val posOf : int -> pos val spanOf : int * int -> span + (* To monitor in which modules the elaboration phase finds errors *) val startElabStructure : string -> unit val stopElabStructureAndGetErrored : string -> bool (* Did the module elab encounter errors? *) diff --git a/src/getinfo.sig b/src/getinfo.sig new file mode 100644 index 00000000..317b7e79 --- /dev/null +++ b/src/getinfo.sig @@ -0,0 +1,31 @@ +(* Copyright (c) 2012, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature GET_INFO = sig + val getInfo: string (* file:row:col *) -> Print.PD.pp_desc +end + diff --git a/src/getinfo.sml b/src/getinfo.sml new file mode 100644 index 00000000..37c50928 --- /dev/null +++ b/src/getinfo.sml @@ -0,0 +1,270 @@ +(* Copyright (c) 2012, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure GetInfo :> GET_INFO = struct + +structure U = ElabUtilPos +structure E = ElabEnv +structure L = Elab +structure P = Print + +fun isPosIn file row col span = + let + val start = #first span + val end_ = #last span + in + String.isSuffix file (#file span) + andalso + (#line start < row orelse + #line start = row andalso #char start <= col) + andalso + (#line end_ > row orelse + #line end_ = row andalso #char end_ >= col) + + end + +fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = + (#line (#first s1) > #line (#first s2) orelse + (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) + andalso + (#line (#last s1) < #line (#last s2) orelse + (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) + +datatype item = + Kind of L.kind + | Con of L.con + | Exp of L.exp + | Sgn_item of L.sgn_item + | Sgn of L.sgn + | Str of L.str + | Decl of L.decl + +fun getSpan (f: item * E.env) = + case #1 f of + Kind k => #2 k + | Con c => #2 c + | Exp e => #2 e + | Sgn_item si => #2 si + | Sgn s => #2 s + | Str s => #2 s + | Decl d => #2 d + +fun getInfo' file row col = + if not (!Elaborate.incremental) + then P.PD.string "ERROR: urweb daemon is needed to use typeOf command" + else + case ModDb.lookupModAndDepsIncludingErrored (Compiler.moduleOf file) of + NONE => P.PD.string ("ERROR: No module found: " ^ Compiler.moduleOf file) + | SOME (modDecl, deps) => + let + val () = U.mliftConInCon := E.mliftConInCon + + (* Adding signature of dependencies to environment *) + val env = List.foldl (fn (d, e) => E.declBinds e d) E.empty deps + + (* Adding previous declarations in file to environment *) + (* "open " statements are already translated during elaboration *) + (* They get added to the env here "unprefixed" *) + val env = + case #1 modDecl of + L.DStr (name, _, sgn, str) => + (case #1 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) + | L.DFfiStr _ => env + | _ => env + + (* Basis and Top need to be added to the env explicitly *) + val env = + case ModDb.lookupModAndDepsIncludingErrored "Top" of + NONE => raise Fail "ERROR: Top module not found in ModDb" + | SOME ((L.DStr (_, top_n, topSgn, topStr), _), _) => + #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) + | _ => raise Fail "ERROR: Impossible" + val env = + case ModDb.lookupModAndDepsIncludingErrored "Basis" of + NONE => raise Fail "ERROR: Top module not found in ModDb" + | SOME ((L.DFfiStr (_, basis_n, sgn), _), _) => + #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) + | _ => raise Fail "ERROR: Impossible" + + (* Just use ElabPrint functions. *) + (* These are better for compiler error message, 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] + ] + + (* 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, _) => + 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")]) + | Exp (L.ERel n, _) => + SOME ((let val found = E.lookupERel env n + in + P.box [ P.PD.string (#1 found) + , 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.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)) + | Exp e => NONE + | Kind k => NONE + | Con c => NONE + | Sgn_item si => NONE + | Sgn s => NONE + | Str s => NONE + | Decl d => NONE) + + fun add env item span acc = + if not (isPosIn file 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, span)) + | SOME (desc', span') => + if isSmallerThan span span' + then + (case printGoodPart env item span of + NONE => SOME (desc', span') + | SOME desc => SOME (desc, span)) + else SOME (desc', span') + in + {smallest = smallest, smallestgoodpart = smallestgoodpart} + end + + (* 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 = Decl (#1 modDecl, { file = file + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , span = { file = file + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} } + , env = env } + } + modDecl + in + case #smallestgoodpart result of + NONE => printLiterally (#smallest result) + | SOME (desc, span) => desc + end + +fun getInfo loc = + case String.tokens (fn ch => ch = #":") loc of + file :: rowStr :: colStr :: nil => + (case (Int.fromString rowStr, Int.fromString colStr) of + (SOME row, SOME col) => getInfo' file row col + | _ => P.PD.string "ERROR: Wrong typeOf input format, should be ") + | _ => P.PD.string "ERROR: Wrong typeOf input format, should be " +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bb5d2166..bbee8c90 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -139,8 +139,8 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () - fun typeOf loc = - (Print.print (Compiler.typeOf loc); + fun getInfo loc = + (Print.print (GetInfo.getInfo loc); raise Code OS.Process.success) fun add_class (class, num) = @@ -249,8 +249,8 @@ fun oneRun args = NONE), ("moduleOf", ONE ("", printModuleOf), SOME "print module name of and exit"), - ("typeOf", ONE ("", typeOf), - SOME "print type of expression at and exit"), + ("getInfo", ONE ("", getInfo), + SOME "print info of expression at and exit"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("", "", add_class), diff --git a/src/mod_db.sig b/src/mod_db.sig index 40cd52e2..fb396603 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -36,7 +36,8 @@ signature MOD_DB = sig val lookup : Source.decl -> Elab.decl option - val lookupForTooling : string -> (Elab.decl * Elab.decl list) option + val lookupModAndDepsIncludingErrored: + string -> (Elab.decl * Elab.decl list) option (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index 57d85195..c821a0bb 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -43,7 +43,7 @@ structure IM = IntBinaryMap type oneMod = {Decl : decl, When : Time.time, Deps : SS.set, - HasErrors: bool + HasErrors: bool (* We're saving modules with errors so tooling can find them *) } val byName = ref (SM.empty : oneMod SM.map) @@ -52,6 +52,7 @@ val byId = ref (IM.empty : string IM.map) fun reset () = (byName := SM.empty; byId := IM.empty) +(* For debug purposes *) fun printByName (bn: oneMod SM.map): unit = (TextIO.print ("Contents of ModDb.byName: \n"); List.app (fn tup => @@ -70,17 +71,6 @@ fun printByName (bn: oneMod SM.map): unit = end) (SM.listItemsi bn)) -fun printById (bi: string IM.map): unit = - (TextIO.print ("Contents of ModDb.byId: \n"); - List.app (fn tup => - let - val i = #1 tup - val name = #2 tup - in - TextIO.print (" " ^ Int.toString i ^": "^ name ^"\n") - end) - (IM.listItemsi bi)) - fun dContainsUndeterminedUnif d = ElabUtil.Decl.exists {kind = fn _ => false, @@ -112,6 +102,9 @@ fun insert (d, tm, hasErrors) = NONE => false | SOME r => #When r = tm andalso not (#HasErrors r) + (* We save results of error'd compiler passes *) + (* so modules that still have undetermined unif variables *) + (* should not be reused since those are unsuccessfully compiled *) andalso not (dContainsUndeterminedUnif (#Decl r)) in if skipIt then @@ -182,7 +175,6 @@ fun insert (d, tm, hasErrors) = }); byId := IM.insert (!byId, n, x) (* printByName (!byName) *) - (* printById (!byId) *) end end end @@ -207,19 +199,19 @@ fun lookup (d : Source.decl) = NONE) | _ => NONE -fun lookupForTooling name = +fun lookupModAndDepsIncludingErrored name = case SM.find (!byName, name) of NONE => NONE | SOME m => - SOME (#Decl m, List.map (fn a => #Decl a) - (List.mapPartial - (fn d => SM.find (!byName, d)) - (* Clumsy way of adding Basis and Top without adding doubles *) - (["Basis", "Top"] - @ - (List.filter - (fn x => x <> "Basis" andalso x <> "Top") - (SS.listItems (#Deps m)))))) + let + val deps = SS.listItems (#Deps m) + (* Clumsy way of adding Basis and Top without adding doubles *) + val deps = List.filter (fn x => x <> "Basis" andalso x <> "Top") deps + val deps = ["Basis", "Top"] @ deps + val foundDepModules = List.mapPartial (fn d => SM.find (!byName, d)) deps + in + SOME (#Decl m, List.map (fn a => #Decl a) foundDepModules) + end val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) diff --git a/src/sources b/src/sources index e25ccd2e..20d77483 100644 --- a/src/sources +++ b/src/sources @@ -274,6 +274,9 @@ $(SRC)/checknest.sml $(SRC)/compiler.sig $(SRC)/compiler.sml +$(SRC)/getinfo.sig +$(SRC)/getinfo.sml + $(SRC)/demo.sig $(SRC)/demo.sml -- cgit v1.2.3 From 25b0685cefe772c73562665a4cc8d2d40e5ff600 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 13:58:01 +0100 Subject: Use elabFile completely instead of rebuilding it partially --- src/compiler.sml | 2 +- src/elaborate.sig | 5 +++- src/elaborate.sml | 4 ++- src/lsp.sml | 73 ++++++++++++++++++++++++++----------------------------- 4 files changed, 42 insertions(+), 42 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index fab939f9..ab7b86b4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1283,7 +1283,7 @@ val elaborate = { in Elaborate.elabFile basis (OS.FileSys.modTime basisF) topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) - ElabEnv.empty file + ElabEnv.empty (fn env => env) file end, print = ElabPrint.p_file ElabEnv.empty } diff --git a/src/elaborate.sig b/src/elaborate.sig index 88ea068f..d6747241 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -29,7 +29,10 @@ signature ELABORATE = sig val elabFile : Source.sgn_item list -> Time.time -> Source.decl list -> Source.sgn_item list -> Time.time - -> ElabEnv.env -> Source.file -> Elab.file + -> ElabEnv.env + -> (ElabEnv.env -> ElabEnv.env) (* Adapt env after stdlib but before elaborate *) + -> Source.file + -> Elab.file val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option diff --git a/src/elaborate.sml b/src/elaborate.sml index d5e190fa..85234775 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4760,7 +4760,7 @@ and elabStr (env, denv) (str, loc) = fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env -fun elabFile basis basis_tm topStr topSgn top_tm env file = +fun elabFile basis basis_tm topStr topSgn top_tm env changeEnv file = let val () = ModDb.snapshot () val () = ErrorMsg.resetStructureTracker () @@ -4857,6 +4857,8 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + val env' = changeEnv env' + fun elabDecl' x = (resetKunif (); resetCunif (); diff --git a/src/lsp.sml b/src/lsp.sml index 34209231..b5a92683 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,9 +417,7 @@ end structure SM = BinaryMapFn(SK) type fileState = - { envOfPreviousModules : ElabEnv.env - , decls : Elab.decl list - } + { decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -498,6 +496,8 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls then () else raise Fail ("Can only handle .ur files for now") val () = Elaborate.unifyMore := true + (* To reuse Basis and Top *) + val () = Elaborate.incremental := true (* Parsing .urp *) val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of NONE => raise LspError (InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) @@ -531,28 +531,35 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls } end) modulesBeforeThisFile - (* Parsing Basis and Top .urs *) + (* Parsing Basis and Top *) + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + val parsedBasisUrs = - case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs") of - NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ (Settings.libFile "basis.urs"))) + case C.run (C.transform C.parseUrs "parseUrs") basisF of + NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) | SOME a => a val parsedTopUrs = - case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs") of - NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ (Settings.libFile "top.urs"))) + case C.run (C.transform C.parseUrs "parseUrs") topF of + NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) | SOME a => a - (* Building env with previous .urs files *) - val envWithStdLib = - addSgnToEnv - (addSgnToEnv ElabEnv.empty parsedBasisUrs (Settings.libFile "basis.urs") true) - parsedTopUrs (Settings.libFile "top.urs") true - val envBeforeThisFile = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envWithStdLib parsedUrss + val parsedTopUr = + case C.run (C.transform C.parseUr "parseUr") topF' of + NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + | SOME a => a + (* Parsing .ur and .urs of current file *) - val (parsedUrs: (Source.sgn_item list) option) = + val (parsedUrs: Source.sgn option) = (if OS.FileSys.access (fileName ^ "s", []) then case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of NONE => NONE - | SOME a => SOME a + | SOME a => SOME ( Source.SgnConst a + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) else NONE) handle ex => NONE val () = ErrorMsg.resetErrors () @@ -562,34 +569,22 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls case parsedUrO of NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) | SOME parsedUr => - (* .ur file found -> typecheck *) + (* Parsing of .ur succeeded *) let - val (str, sgn', gs) = - Elaborate.elabStr - (envBeforeThisFile, Disjoint.empty) - (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - val () = - (* .urs file found -> check and compare with .ur file *) - (case parsedUrs of - NONE => () - | SOME parsedUrs => - let - val (sgn, gs) = Elaborate.elabSgn - (envBeforeThisFile, Disjoint.empty) - ( Source.SgnConst parsedUrs - , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}); - in - Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn - end) + val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val res = Elaborate.elabFile + parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty + (* Adding urs's of previous modules to env *) + (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) + , loc )] (* report back errors (as Diagnostics) *) val errors = ErrorMsg.readErrorLog () - val decls = case str of - (Elab.StrConst decls, _) => decls + val decls = case List.last res of + (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { envOfPreviousModules = envBeforeThisFile - , decls = decls - }, + (SOME { decls = decls }, List.map errorToDiagnostic errors) end end -- cgit v1.2.3