From bc67c873a23309d2ef9e8365e0a9b7f8f15577ca Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Mon, 29 Jul 2019 11:09:28 +0200 Subject: Don't use interfaces anymore for ModDb validity, but check for undetermined unif vars --- src/main.mlton.sml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'src/main.mlton.sml') diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfa40265..cb7c8a77 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -435,10 +435,12 @@ val () = (Globals.setResetTime (); wrs = [Socket.sockDesc sock], exs = [], timeout = SOME (Time.fromSeconds 1)}))) then - (app (fn arg => send (sock, arg ^ "\n")) args; + (TextIO.print "Using daemon\n"; + app (fn arg => send (sock, arg ^ "\n")) args; send (sock, "\n"); OS.Process.exit (wait ())) else (OS.FileSys.remove socket; raise OS.SysErr ("", NONE)) - end handle OS.SysErr _ => OS.Process.exit (oneRun args)) + end handle OS.SysErr _ => + OS.Process.exit (oneRun args)) -- cgit v1.2.3 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.sig | 1 + src/compiler.sml | 187 +++++++++++ src/elab_util_pos.sig | 63 ++++ src/elab_util_pos.sml | 910 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/main.mlton.sml | 6 + src/mod_db.sig | 2 + src/mod_db.sml | 9 + src/search.sig | 5 + src/search.sml | 8 + src/sources | 3 + 10 files changed, 1194 insertions(+) create mode 100644 src/elab_util_pos.sig create mode 100644 src/elab_util_pos.sml (limited to 'src/main.mlton.sml') diff --git a/src/compiler.sig b/src/compiler.sig index 6ed2f9a6..7f724b0f 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -215,6 +215,7 @@ 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 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 diff --git a/src/elab_util_pos.sig b/src/elab_util_pos.sig new file mode 100644 index 00000000..f616f7f3 --- /dev/null +++ b/src/elab_util_pos.sig @@ -0,0 +1,63 @@ +(* Copyright (c) 2008-2010, 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 ELAB_UTIL_POS = sig + + val mliftConInCon : (int -> Elab.con -> Elab.con) ref + + structure Decl : sig + datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + + val fold : {kind : Elab.kind * 'state -> 'state, + con : Elab.con * 'state -> 'state, + exp : Elab.exp * 'state -> 'state, + sgn_item : Elab.sgn_item * 'state -> 'state, + sgn : Elab.sgn * 'state -> 'state, + str : Elab.str * 'state -> 'state, + decl : Elab.decl * 'state -> 'state} + -> 'state -> Elab.decl -> 'state + + val foldB : {kind : 'context * Elab.kind * 'state -> 'state, + con : 'context * Elab.con * 'state -> 'state, + exp : 'context * Elab.exp * 'state -> 'state, + sgn_item : 'context * Elab.sgn_item * 'state -> 'state, + sgn : 'context * Elab.sgn * 'state -> 'state, + str : 'context * Elab.str * 'state -> 'state, + decl : 'context * Elab.decl * 'state -> 'state, + bind: 'context * binder -> 'context + } + -> 'context -> 'state -> Elab.decl -> 'state + end + +end diff --git a/src/elab_util_pos.sml b/src/elab_util_pos.sml new file mode 100644 index 00000000..d8d1bfdd --- /dev/null +++ b/src/elab_util_pos.sml @@ -0,0 +1,910 @@ +(* Copyright (c) 2008-2010, 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 ElabUtilPos :> ELAB_UTIL_POS = struct + +open Elab + +structure S = Search + +structure Kind = struct + +fun mapfoldB {kind, bind} = + let + fun mfk ctx k acc = + S.bindPWithPos (mfk' ctx k acc, kind ctx) + + and mfk' ctx (kAll as (k, loc)) = + case k of + KType => S.return2 kAll + + | KArrow (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (KArrow (k1', k2'), loc))) + + | KName => S.return2 kAll + + | KRecord k => + S.map2 (mfk ctx k, + fn k' => + (KRecord k', loc)) + + | KUnit => S.return2 kAll + + | KTuple ks => + S.map2 (ListUtil.mapfold (mfk ctx) ks, + fn ks' => + (KTuple ks', loc)) + + | KError => S.return2 kAll + + | KUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KUnif _ => S.return2 kAll + + | KTupleUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KTupleUnif (loc, nks, r) => + S.map2 (ListUtil.mapfold (fn (n, k) => + S.map2 (mfk ctx k, + fn k' => + (n, k'))) nks, + fn nks' => + (KTupleUnif (loc, nks', r), loc)) + + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) + in + mfk + end + +end + +val mliftConInCon = ref (fn n : int => fn c : con => (raise Fail "You didn't set ElabUtil.mliftConInCon!") : con) + +structure Con = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + +fun mapfoldB {kind = fk, con = fc, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, s) => bind (ctx, RelK s)} + + fun mfc ctx c acc = + S.bindPWithPos (mfc' ctx c acc, fc ctx) + + and mfc' ctx (cAll as (c, loc)) = + case c of + TFun (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (TFun (c1', c2'), loc))) + | TCFun (e, x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (TCFun (e, x, k', c'), loc))) + | TDisjoint (c1, c2, c3) => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfc ctx c2, + fn c2' => + S.map2 (mfc ctx c3, + fn c3' => + (TDisjoint (c1', c2', c3'), loc)))) + | TRecord c => + S.map2 (mfc ctx c, + fn c' => + (TRecord c', loc)) + + | CRel _ => S.return2 cAll + | CNamed _ => S.return2 cAll + | CModProj _ => S.return2 cAll + | CApp (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CApp (c1', c2'), loc))) + | CAbs (x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (CAbs (x, k', c'), loc))) + + | CName _ => S.return2 cAll + + | CRecord (k, xcs) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (ListUtil.mapfold (fn (x, c) => + S.bind2 (mfc ctx x, + fn x' => + S.map2 (mfc ctx c, + fn c' => + (x', c')))) + xcs, + fn xcs' => + (CRecord (k', xcs'), loc))) + | CConcat (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CConcat (c1', c2'), loc))) + | CMap (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (CMap (k1', k2'), loc))) + + | CUnit => S.return2 cAll + + | CTuple cs => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (CTuple cs', loc)) + + | CProj (c, n) => + S.map2 (mfc ctx c, + fn c' => + (CProj (c', n), loc)) + + | CError => S.return2 cAll + | CUnif (nl, _, _, _, ref (Known c)) => mfc' ctx (!mliftConInCon nl c) + | CUnif _ => S.return2 cAll + + | CKAbs (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (CKAbs (x, c'), loc)) + | CKApp (c, k) => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfk ctx k, + fn k' => + (CKApp (c', k'), loc))) + | TKFun (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (TKFun (x, c'), loc)) + in + mfc + end + +end + +structure Exp = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + +fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun doVars ((p, _), ctx) = + case p of + PVar xt => bind (ctx, RelE xt) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => doVars (p, ctx) + | PRecord xpcs => + foldl (fn ((_, p, _), ctx) => doVars (p, ctx)) + ctx xpcs + + fun mfe ctx e acc = + S.bindPWithPos (mfe' ctx e acc, fe ctx) + + and mfe' ctx (eAll as (e, loc)) = + case e of + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll + | ENamed _ => S.return2 eAll + | EModProj _ => S.return2 eAll + | EApp (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EApp (e1', e2'), loc))) + | EAbs (x, dom, ran, e) => + S.bind2 (mfc ctx dom, + fn dom' => + S.bind2 (mfc ctx ran, + fn ran' => + S.map2 (mfe (bind (ctx, RelE (x, dom'))) e, + fn e' => + (EAbs (x, dom', ran', e'), loc)))) + + | ECApp (e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (ECApp (e', c'), loc))) + | ECAbs (expl, x, k, e) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfe (bind (ctx, RelC (x, k))) e, + fn e' => + (ECAbs (expl, x, k', e'), loc))) + + | ERecord xes => + S.map2 (ListUtil.mapfold (fn (x, e, t) => + S.bind2 (mfc ctx x, + fn x' => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (x', e', t'))))) + xes, + fn xes' => + (ERecord xes', loc)) + | EField (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (EField (e', c', {field = field', rest = rest'}), loc))))) + | EConcat (e1, c1, e2, c2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfe ctx e2, + fn e2' => + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) + | ECut (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (ECut (e', c', {field = field', rest = rest'}), loc))))) + + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) + + | ECase (e, pes, {disc, result}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (ListUtil.mapfold (fn (p, e) => + let + fun pb ((p, _), ctx) = + case p of + PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfe (pb (p', ctx)) e, + fn e' => (p', e'))) + end) pes, + fn pes' => + S.bind2 (mfc ctx disc, + fn disc' => + S.map2 (mfc ctx result, + fn result' => + (ECase (e', pes', {disc = disc', result = result'}), loc))))) + + | EError => S.return2 eAll + | EUnif (ref (SOME e)) => mfe ctx e + | EUnif _ => S.return2 eAll + + | ELet (des, e, t) => + let + val (des, ctx') = foldl (fn (ed, (des, ctx)) => + let + val ctx' = + case #1 ed of + EDVal (p, _, _) => doVars (p, ctx) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) + ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, + fn ed' => ed' :: des')), + ctx') + end) + (S.return2 [], ctx) des + in + S.bind2 (des, + fn des' => + S.bind2 (mfe ctx' e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (ELet (rev des', e', t'), loc)))) + end + + | EKAbs (x, e) => + S.map2 (mfe (bind (ctx, RelK x)) e, + fn e' => + (EKAbs (x, e'), loc)) + | EKApp (e, k) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfk ctx k, + fn k' => + (EKApp (e', k'), loc))) + + and mfp ctx (pAll as (p, loc)) = + case p of + PVar (x, t) => + S.map2 (mfc ctx t, + fn t' => + (PVar (x, t'), loc)) + | PPrim _ => S.return2 pAll + | PCon (dk, pc, args, po) => + S.bind2 (ListUtil.mapfold (mfc ctx) args, + fn args' => + S.map2 ((case po of + NONE => S.return2 NONE + | SOME p => S.map2 (mfp ctx p, SOME)), + fn po' => + (PCon (dk, pc, args', po'), loc))) + | PRecord xps => + S.map2 (ListUtil.mapfold (fn (x, p, c) => + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfc ctx c, + fn c' => + (x, p', c')))) xps, + fn xps' => + (PRecord xps', loc)) + + and mfed ctx (dAll as (d, loc)) = + case d of + EDVal (p, t, e) => + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (EDVal (p, t', e'), loc))) + | EDValRec vis => + let + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (EDValRec vis', loc)) + end + + and mfvi ctx (x, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, c', e'))) + in + mfe + end + +end + +structure Sgn = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind, con, sgn_item, sgn, bind} = + let + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val con = Con.mapfoldB {kind = kind, con = con, bind = bind'} + + val kind = Kind.mapfoldB {kind = kind, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun sgi ctx si acc = + S.bindPWithPos (sgi' ctx si acc, sgn_item ctx) + + and sgi' ctx (siAll as (si, loc)) = + case si of + SgiConAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiConAbs (x, n, k'), loc)) + | SgiCon (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiCon (x, n, k', c'), loc))) + | SgiDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xs, xncs'))) dts, + fn dts' => + (SgiDatatype dts', loc)) + | SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (SgiDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | SgiVal (x, n, c) => + S.map2 (con ctx c, + fn c' => + (SgiVal (x, n, c'), loc)) + | SgiStr (im, x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiStr (im, x, n, s'), loc)) + | SgiSgn (x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiSgn (x, n, s'), loc)) + | SgiConstraint (c1, c2) => + S.bind2 (con ctx c1, + fn c1' => + S.map2 (con ctx c2, + fn c2' => + (SgiConstraint (c1', c2'), loc))) + | SgiClassAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiClassAbs (x, n, k'), loc)) + | SgiClass (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiClass (x, n, k', c'), loc))) + + and sg ctx s acc = + S.bindPWithPos (sg' ctx s acc, sgn ctx) + + and sg' ctx (sAll as (s, loc)) = + case s of + SgnConst sgis => + S.map2 (ListUtil.mapfoldB (fn (ctx, si) => + (case #1 si of + SgiConAbs (x, n, k) => + bind (ctx, NamedC (x, n, k, NONE)) + | SgiCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | SgiDatatype dts => + foldl (fn ((x, n, ks, _), ctx) => + let + val k' = (KType, loc) + val k = foldl (fn (_, k) => (KArrow (k', k), loc)) + k' ks + in + bind (ctx, NamedC (x, n, k, NONE)) + end) ctx dts + | SgiDatatypeImp (x, n, m1, ms, s, _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m1, ms, s), loc))) + | SgiVal _ => ctx + | SgiStr (_, x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | SgiSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | SgiConstraint _ => ctx + | SgiClassAbs (x, n, k) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), NONE)) + | SgiClass (x, n, k, c) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), SOME c)), + sgi ctx si)) ctx sgis, + fn sgis' => + (SgnConst sgis', loc)) + + | SgnVar _ => S.return2 sAll + | SgnFun (m, n, s1, s2) => + S.bind2 (sg ctx s1, + fn s1' => + S.map2 (sg (bind (ctx, Str (m, n, s1'))) s2, + fn s2' => + (SgnFun (m, n, s1', s2'), loc))) + | SgnProj _ => S.return2 sAll + | SgnWhere (sgn, ms, x, c) => + S.bind2 (sg ctx sgn, + fn sgn' => + S.map2 (con ctx c, + fn c' => + (SgnWhere (sgn', ms, x, c'), loc))) + | SgnError => S.return2 sAll + in + sg + end + +end + +structure Decl = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = fst, decl = fd, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Exp.RelK x => RelK x + | Exp.RelC x => RelC x + | Exp.NamedC x => NamedC x + | Exp.RelE x => RelE x + | Exp.NamedE x => NamedE x + in + bind (ctx, b') + end + val mfe = Exp.mapfoldB {kind = fk, con = fc, exp = fe, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Sgn.RelK x => RelK x + | Sgn.RelC x => RelC x + | Sgn.NamedC x => NamedC x + | Sgn.Sgn x => Sgn x + | Sgn.Str x => Str x + in + bind (ctx, b') + end + val mfsg = Sgn.mapfoldB {kind = fk, con = fc, sgn_item = fsgi, sgn = fsg, bind = bind'} + + fun mfst ctx str acc = + S.bindPWithPos (mfst' ctx str acc, fst ctx) + + and mfst' ctx (strAll as (str, loc)) = + case str of + StrConst ds => + S.map2 (ListUtil.mapfoldB (fn (ctx, d) => + (case #1 d of + DCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | DDatatype dts => + let + fun doOne ((x, n, xs, xncs), ctx) = + let + val ctx = bind (ctx, NamedC (x, n, (KType, loc), NONE)) + in + foldl (fn ((x, _, co), ctx) => + let + val t = + case co of + NONE => CNamed n + | SOME t => TFun (t, (CNamed n, loc)) + + val k = (KType, loc) + val t = (t, loc) + val t = foldr (fn (x, t) => + (TCFun (Explicit, + x, + k, + t), loc)) + t xs + in + bind (ctx, NamedE (x, t)) + end) + ctx xncs + end + in + foldl doOne ctx dts + end + | DDatatypeImp (x, n, m, ms, x', _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m, ms, x'), loc))) + | DVal (x, _, c, _) => + bind (ctx, NamedE (x, c)) + | DValRec vis => + foldl (fn ((x, _, c, _), ctx) => bind (ctx, NamedE (x, c))) ctx vis + | DSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | DStr (x, n, sgn, _) => + bind (ctx, Str (x, n, sgn)) + | DFfiStr (x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | DConstraint _ => ctx + | DExport _ => ctx + | DTable (tn, x, n, c, _, pc, _, cc) => + let + val ct = (CModProj (n, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DSequence (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DDatabase _ => ctx + | DCookie (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) + | DTask _ => ctx + | DPolicy _ => ctx + | DOnError _ => ctx + | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)), + mfd ctx d)) ctx ds, + fn ds' => (StrConst ds', loc)) + | StrVar _ => S.return2 strAll + | StrProj (str, x) => + S.map2 (mfst ctx str, + fn str' => + (StrProj (str', x), loc)) + | StrFun (x, n, sgn1, sgn2, str) => + S.bind2 (mfsg ctx sgn1, + fn sgn1' => + S.bind2 (mfsg ctx sgn2, + fn sgn2' => + S.map2 (mfst ctx str, + fn str' => + (StrFun (x, n, sgn1', sgn2', str'), loc)))) + | StrApp (str1, str2) => + S.bind2 (mfst ctx str1, + fn str1' => + S.map2 (mfst ctx str2, + fn str2' => + (StrApp (str1', str2'), loc))) + | StrError => S.return2 strAll + + and mfd ctx d acc = + S.bindPWithPos (mfd' ctx d acc, fd ctx) + + and mfd' ctx (dAll as (d, loc)) = + case d of + DCon (x, n, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc ctx c, + fn c' => + (DCon (x, n, k', c'), loc))) + | DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (x, n, xs, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) + | DDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (DDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | DVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (DVal vi', loc)) + | DValRec vis => + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (DValRec vis', loc)) + | DSgn (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DSgn (x, n, sgn'), loc)) + | DStr (x, n, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DStr (x, n, sgn', str'), loc))) + | DFfiStr (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DFfiStr (x, n, sgn'), loc)) + | DConstraint (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (DConstraint (c1', c2'), loc))) + | DExport (en, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DExport (en, sgn', str'), loc))) + + | DTable (tn, x, n, c, pe, pc, ce, cc) => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfe ctx pe, + fn pe' => + S.bind2 (mfc ctx pc, + fn pc' => + S.bind2 (mfe ctx ce, + fn ce' => + S.map2 (mfc ctx cc, + fn cc' => + (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) + | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) + + | DDatabase _ => S.return2 dAll + + | DCookie (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (tn, x, n, c'), loc)) + | DStyle _ => S.return2 dAll + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + fn e1' => + (DPolicy e1', loc)) + | DOnError _ => S.return2 dAll + | DFfi (x, n, modes, t) => + S.map2 (mfc ctx t, + fn t' => + (DFfi (x, n, modes, t'), loc)) + + and mfvi ctx (x, n, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, n, c', e'))) + in + mfd + end + + fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a = + case mapfoldB {kind = fn () => fn k => fn st => S.Continue (#1 k, kind (k, st)), + con = fn () => fn c => fn st => S.Continue (#1 c, con (c, st)), + exp = fn () => fn e => fn st => S.Continue (#1 e, exp (e, st)), + sgn_item = fn () => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (sgi, st)), + sgn = fn () => fn s => fn st => S.Continue (#1 s, sgn (s, st)), + str = fn () => fn str' => fn st => S.Continue (#1 str', str (str', st)), + decl = fn () => fn d => fn st => S.Continue (#1 d, decl (d, st)), + bind = fn ((), _) => () + } () d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible" + + fun foldB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx (st : 'a) d : 'a = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (#1 k, kind (ctx, k, st)), + con = fn ctx => fn c => fn st => S.Continue (#1 c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (#1 e, exp (ctx, e, st)), + sgn_item = fn ctx => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (ctx, sgi, st)), + sgn = fn ctx => fn s => fn st => S.Continue (#1 s, sgn (ctx, s, st)), + str = fn ctx => fn str' => fn st => S.Continue (#1 str', str (ctx, str', st)), + decl = fn ctx => fn d => fn st => S.Continue (#1 d, decl (ctx, d, st)), + bind = bind + } ctx d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.foldB: Impossible" + end +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index cb7c8a77..8e70e398 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -139,6 +139,10 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () + fun typeOf loc = + (Print.print (Compiler.typeOf loc); + raise Code OS.Process.success) + fun add_class (class, num) = case Int.fromString num of NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") @@ -245,6 +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"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("", "", add_class), diff --git a/src/mod_db.sig b/src/mod_db.sig index c45fd203..40cd52e2 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -36,6 +36,8 @@ signature MOD_DB = sig val lookup : Source.decl -> Elab.decl option + val lookupForTooling : string -> (Elab.decl * Elab.decl list) option + (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit val revert : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index de428570..fdf6d5ab 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -207,6 +207,15 @@ fun lookup (d : Source.decl) = NONE) | _ => NONE +fun lookupForTooling 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)) + (SS.listItems (#Deps m)))) + val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) diff --git a/src/search.sig b/src/search.sig index ac867146..2de85425 100644 --- a/src/search.sig +++ b/src/search.sig @@ -59,4 +59,9 @@ signature SEARCH = sig * ('state11 -> 'state2 -> ('state11 * 'state2, 'abort) result) -> (('state11 * 'state12) * 'state2, 'abort) result + val bindPWithPos : + (('state11 * 'state12) * 'state2, 'abort) result + * (('state11 * 'state12) -> 'state2 -> ('state11 * 'state2, 'abort) result) + -> (('state11 * 'state12) * 'state2, 'abort) result + end diff --git a/src/search.sml b/src/search.sml index 563496fe..5e4e135f 100644 --- a/src/search.sml +++ b/src/search.sml @@ -70,4 +70,12 @@ fun bindP (r, f) = ((x', pos), acc')) | Return x => Return x +fun bindPWithPos (r, f) = + case r of + Continue ((x, pos), acc) => + map (f (x, pos) acc, + fn (x', acc') => + ((x', pos), acc')) + | Return x => Return x + end diff --git a/src/sources b/src/sources index 851cdc16..e25ccd2e 100644 --- a/src/sources +++ b/src/sources @@ -69,6 +69,9 @@ $(SRC)/elab.sml $(SRC)/elab_util.sig $(SRC)/elab_util.sml +$(SRC)/elab_util_pos.sig +$(SRC)/elab_util_pos.sml + $(SRC)/elab_env.sig $(SRC)/elab_env.sml -- 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/main.mlton.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/main.mlton.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 f5bfb7ab3a23485230a97b87ac5839eea8c79486 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 8 Dec 2019 20:50:40 +0100 Subject: Added initial version of lsp --- src/json.sig | 13 +++ src/json.sml | 275 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/lsp.sig | 3 + src/lsp.sml | 159 +++++++++++++++++++++++++++++++ src/main.mlton.sml | 1 + src/sources | 6 ++ 6 files changed, 457 insertions(+) create mode 100644 src/json.sig create mode 100644 src/json.sml create mode 100644 src/lsp.sig create mode 100644 src/lsp.sml (limited to 'src/main.mlton.sml') diff --git a/src/json.sig b/src/json.sig new file mode 100644 index 00000000..f92ef495 --- /dev/null +++ b/src/json.sig @@ -0,0 +1,13 @@ +signature JSON = sig + datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + + val parse: string -> json + val print: json -> string +end diff --git a/src/json.sml b/src/json.sml new file mode 100644 index 00000000..fab15a6c --- /dev/null +++ b/src/json.sml @@ -0,0 +1,275 @@ +(******************************************************************************* +* Standard ML JSON parser +* Copyright (C) 2010 Gian Perrone +* +* This program is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, either version 3 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program. If not, see . +******************************************************************************) + +signature JSON_CALLBACKS = +sig + type json_data + + val json_object : json_data list -> json_data + val json_pair : string * json_data -> json_data + val json_array : json_data list -> json_data + val json_value : json_data -> json_data + val json_string : string -> json_data + val json_int : int -> json_data + val json_real : real -> json_data + val json_bool : bool -> json_data + val json_null : unit -> json_data + + val error_handle : string * int * string -> json_data +end + +functor JSONParser (Callbacks : JSON_CALLBACKS) = +struct + type json_data = Callbacks.json_data + + exception JSONParseError of string * int + + val inputData = ref "" + val inputPosition = ref 0 + + fun isDigit () = Char.isDigit (String.sub (!inputData,0)) + + fun ws () = while (String.isPrefix " " (!inputData) orelse + String.isPrefix "\n" (!inputData) orelse + String.isPrefix "\t" (!inputData) orelse + String.isPrefix "\r" (!inputData)) + do (inputData := String.extract (!inputData, 1, NONE)) + + fun peek () = String.sub (!inputData,0) + fun take () = + String.sub (!inputData,0) before + inputData := String.extract (!inputData, 1, NONE) + + fun matches s = (ws(); String.isPrefix s (!inputData)) + fun consume s = + if matches s then + (inputData := String.extract (!inputData, size s, NONE); + inputPosition := !inputPosition + size s) + else + raise JSONParseError ("Expected '"^s^"'", !inputPosition) + + fun parseObject () = + if not (matches "{") then + raise JSONParseError ("Expected '{'", !inputPosition) + else + (consume "{"; ws (); + if matches "}" then Callbacks.json_object [] before consume "}" + else + (Callbacks.json_object (parseMembers ()) + before (ws (); consume "}"))) + + and parseMembers () = + parsePair () :: + (if matches "," then (consume ","; parseMembers ()) else []) + + and parsePair () = + Callbacks.json_pair (parseString (), + (ws(); consume ":"; parseValue ())) + + and parseArray () = + if not (matches "[") then + raise JSONParseError ("Expected '['", !inputPosition) + else + (consume "["; + if matches "]" then + Callbacks.json_array [] before consume "]" + else + Callbacks.json_array (parseElements ()) before (ws (); consume "]")) + + and parseElements () = + parseValue () :: + (if matches "," then (consume ","; parseElements ()) else []) + + and parseValue () = + Callbacks.json_value ( + if matches "\"" then Callbacks.json_string (parseString ()) else + if matches "-" orelse isDigit () then parseNumber () else + if matches "true" then Callbacks.json_bool true before consume "true" else + if matches "false" then Callbacks.json_bool false before consume "false" else + if matches "null" then Callbacks.json_null () before consume "null" else + if matches "[" then parseArray () else + if matches "{" then parseObject () else + raise JSONParseError ("Expected value", !inputPosition)) + + and parseString () = + (ws () ; + consume ("\"") ; + parseChars () before consume "\"") + + and parseChars () = + let + fun pickChars s = + if peek () = #"\"" (* " *) then s else + pickChars (s ^ String.str (take ())) + in + pickChars "" + end + + and parseNumber () = + let + val i = parseInt () + in + if peek () = #"e" orelse peek () = #"E" then + Callbacks.json_int (valOf (Int.fromString (i^parseExp()))) + else if peek () = #"." then + let + val f = parseFrac() + + val f' = if peek() = #"e" orelse peek() = #"E" then + i ^ f ^ parseExp () + else i ^ f + in + Callbacks.json_real (valOf (Real.fromString f')) + end + else Callbacks.json_int (valOf (Int.fromString i)) + end + + and parseInt () = + let + val f = + if peek () = #"0" then + raise JSONParseError ("Invalid number", !inputPosition) + else if peek () = #"-" then (take (); "~") + else String.str (take ()) + in + f ^ parseDigits () + end + + and parseDigits () = + let + val r = ref "" + in + (while Char.isDigit (peek ()) do + r := !r ^ String.str (take ()); + !r) + end + + and parseFrac () = + (consume "." ; + "." ^ parseDigits ()) + + and parseExp () = + let + val _ = + if peek () = #"e" orelse + peek () = #"E" then take () + else + raise JSONParseError ("Invalid number", !inputPosition) + + val f = if peek () = #"-" then (take (); "~") + else if peek () = #"+" then (take (); "") + else "" + in + "e" ^ f ^ parseDigits () + end + + fun parse s = + (inputData := s ; + inputPosition := 0 ; + parseObject ()) handle JSONParseError (m,p) => + Callbacks.error_handle (m,p,!inputData) +end + +structure JsonIntermAst = +struct +datatype ast = + Array of ast list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Pair of (string * ast) + | Obj of ast list +end + +structure Json :> JSON = struct +datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + +fun fromInterm (interm: JsonIntermAst.ast): json = + case interm of + JsonIntermAst.Array l => Array (List.map fromInterm l) + | JsonIntermAst.Null => Null + | JsonIntermAst.Float r => Float r + | JsonIntermAst.String s => String s + | JsonIntermAst.Bool b => Bool b + | JsonIntermAst.Int i => Int i + | JsonIntermAst.Pair (k,v) => + raise Fail ("JSON Parsing error. Pair of JSON found where it shouldn't. Key = " ^ k) + | JsonIntermAst.Obj l => + Obj + (List.foldl + (fn (a, acc) => + case a of + JsonIntermAst.Pair (k, v) => (k, fromInterm v) :: acc + | JsonIntermAst.Array _ => raise Fail ("JSON Parsing error. Found Array in object instead of key-value pair") + | JsonIntermAst.Null => raise Fail ("JSON Parsing error. Found Null in object instead of key-value pair") + | JsonIntermAst.Float _ => raise Fail ("JSON Parsing error. Found Float in object instead of key-value pair") + | JsonIntermAst.String _ => raise Fail ("JSON Parsing error. Found String in object instead of key-value pair") + | JsonIntermAst.Bool _ => raise Fail ("JSON Parsing error. Found Bool in object instead of key-value pair") + | JsonIntermAst.Int _ => raise Fail ("JSON Parsing error. Found Int in object instead of key-value pair") + | JsonIntermAst.Obj _ => raise Fail ("JSON Parsing error. Found Obj in object instead of key-value pair") + ) [] l) + +structure StandardJsonParserCallbacks = +struct + type json_data = JsonIntermAst.ast + fun json_object l = JsonIntermAst.Obj l + fun json_pair (k,v) = JsonIntermAst.Pair (k,v) + fun json_array l = JsonIntermAst.Array l + fun json_value x = x + fun json_string s = JsonIntermAst.String s + fun json_int i = JsonIntermAst.Int i + fun json_real r = JsonIntermAst.Float r + fun json_bool b = JsonIntermAst.Bool b + fun json_null () = JsonIntermAst.Null + fun error_handle (msg,pos,data) = + raise Fail ("Error: " ^ msg ^ " near " ^ Int.toString pos ^ " data: " ^ + data) +end + +structure MyJsonParser = JSONParser (StandardJsonParserCallbacks) + +fun parse (str: string): json = + fromInterm (MyJsonParser.parse str) +fun print (ast: json): string = + case ast of + Array l => "[" + ^ List.foldl (fn (a, acc) => acc ^ "," ^ print a) "" l + ^ "]" + | Null => "null" + | Float r => Real.toString r + | String s => + "\"" ^ + String.translate + (fn c => if c = #"\"" then "\\\"" else Char.toString c) + s ^ + "\"" + | Bool b => if b then "true" else "false" + | Int i => Int.toString i + | Obj l => "{" + ^ List.foldl (fn ((k, v), acc) => k ^ ": " ^ print v ) "" l + ^ "}" +end diff --git a/src/lsp.sig b/src/lsp.sig new file mode 100644 index 00000000..0dc95801 --- /dev/null +++ b/src/lsp.sig @@ -0,0 +1,3 @@ +signature LSP = sig + val startServer : unit -> unit +end diff --git a/src/lsp.sml b/src/lsp.sml new file mode 100644 index 00000000..1fd50109 --- /dev/null +++ b/src/lsp.sml @@ -0,0 +1,159 @@ +structure Lsp :> LSP = struct + +fun trim (s: substring): substring = + Substring.dropr + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + +fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then NONE + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + +fun readAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: readAllHeaders l + +fun getJsonObjectValue (s: string) (l: (string * Json.json) list): Json.json option = + case List.find (fn tup => #1 tup = s ) l of + NONE => NONE + | SOME tup => SOME (#2 tup) + +fun getJsonObjectValue' (s: string) (l: Json.json): Json.json = + case l of + Json.Obj l => + (case getJsonObjectValue s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s) + | SOME v => v) + | a => raise Fail ("Expected JSON object, got: " ^ Json.print a) + +fun parseInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun parseString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + + +fun parseRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + let + val id = getJsonObjectValue' "id" j + val method = parseString (getJsonObjectValue' "method" j) + val params = getJsonObjectValue' "params" j + in + {id = id, method = method, params = params} + end + + +type textDocumentIdentifier = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } +fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + let + val str = Substring.full (parseString (getJsonObjectValue' "uri" j)) + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + +type position = { line: int + , character: int + } +fun parsePosition (j: Json.json) = + { line = parseInt (getJsonObjectValue' "line" j) + , character = parseInt (getJsonObjectValue' "character" j) + } + +datatype result = Success of Json.json + | Error of (int * string) + +fun handleHover (params: Json.json): result = + let + val textDocument = parseTextDocumentIdentifier (getJsonObjectValue' "textDocument" params) + val position = parsePosition (getJsonObjectValue' "position" params) + val answer = "" + in + Success (Json.Obj (("contents", Json.String answer) :: [])) + end + +fun serverLoop () = + let + val headers = readAllHeaders [] + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + (* val parsed = Json.parse (Substring.string (Substring.trimr 1 (Substring.full request))) (* Trimming last newline *) *) + val parsed = Json.parse request + val requestMessage = parseRequest parsed + fun fail (err: (int * string)) = + Json.print (Json.Obj (("id", #id requestMessage) + :: ("error", Json.Obj (("code", Json.Int (#1 err)) + :: ("message", Json.String (#2 err)) + :: [])) + :: [] + )) + val result: result = + case #method requestMessage of + "initialize" => Success (Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool true) :: [])) :: [])) + | "textDocument/hover" => handleHover (#params requestMessage) + | "shutdown" => Success (Json.Null) + | "exit" => OS.Process.exit OS.Process.success + | method => Error (~32601, "Method not supported: " ^ method) + in + case result of + Success j => TextIO.output (TextIO.stdOut, + Json.print (Json.Obj (("id", #id requestMessage) + :: ("result", j) + :: []))) + | Error (i, err) => + TextIO.output (TextIO.stdOut, + Json.print (Json.Obj (("id", #id requestMessage) + :: ("error", Json.Obj (("code", Json.Int i) + :: ("message", Json.String err) + :: [])) + :: [] + ))) + end + +fun startServer () = + while (1 < 2) do + serverLoop () +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 7f8540f2..1747d702 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -253,6 +253,7 @@ fun oneRun args = SOME "print module name of and exit"), ("getInfo", ONE ("", getInfo), SOME "print info of expression at and exit"), + ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("", "", add_class), diff --git a/src/sources b/src/sources index 20d77483..c407ea2a 100644 --- a/src/sources +++ b/src/sources @@ -277,6 +277,12 @@ $(SRC)/compiler.sml $(SRC)/getinfo.sig $(SRC)/getinfo.sml +$(SRC)/json.sig +$(SRC)/json.sml + +$(SRC)/lsp.sig +$(SRC)/lsp.sml + $(SRC)/demo.sig $(SRC)/demo.sml -- cgit v1.2.3 From 9b00dc724363ac7b0a31687f14cc3bb2f2460f9b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 22:56:29 +0100 Subject: Integrated getInfo into LSP --- src/getinfo.sig | 7 +- src/getinfo.sml | 353 ++++++++++++++++++++++++----------------------------- src/lsp.sml | 69 ++++++++++- src/main.mlton.sml | 6 - 4 files changed, 230 insertions(+), 205 deletions(-) (limited to 'src/main.mlton.sml') diff --git a/src/getinfo.sig b/src/getinfo.sig index 317b7e79..334e19f1 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,6 +26,11 @@ *) signature GET_INFO = sig - val getInfo: string (* file:row:col *) -> Print.PD.pp_desc + val getInfo: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + { line: int , character: int} -> + Print.PD.pp_desc end diff --git a/src/getinfo.sml b/src/getinfo.sml index 37c50928..7925aba3 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,198 +73,163 @@ fun getSpan (f: item * E.env) = | 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 " +fun getInfo env str fileName {line = row, character = col} = + let + val () = U.mliftConInCon := E.mliftConInCon + + (* 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 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) + + (* 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] + ] + + (* 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 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, 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 = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , span = { file = fileName + , first = { line = 0, char = 0} + , last = { line = 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}) + in + case #smallestgoodpart result of + NONE => printLiterally (#smallest result) + | SOME (desc, span) => desc + end end diff --git a/src/lsp.sml b/src/lsp.sml index b5a92683..cfdec863 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,7 +417,8 @@ end structure SM = BinaryMapFn(SK) type fileState = - { decls : Elab.decl list } + { envBeforeThisModule: ElabEnv.env + , decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -572,10 +573,17 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (* Parsing of .ur succeeded *) let val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val envBeforeThisModule = ref ElabEnv.empty 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) + (fn envB => + let + val newEnv = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss + in + (envBeforeThisModule := newEnv; newEnv) + end + ) [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) , loc )] (* report back errors (as Diagnostics) *) @@ -584,7 +592,7 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { decls = decls }, + (SOME { envBeforeThisModule = !envBeforeThisModule, decls = decls }, List.map errorToDiagnostic errors) end end @@ -605,6 +613,59 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +fun readFile (fileName: string): string = + let + val str = TextIO.openIn fileName + fun doReadFile acc = + case TextIO.inputLine str of + NONE => acc + | SOME str => (str ^ "\n" ^ acc) + val res = doReadFile "" + in + (TextIO.closeIn str; res) + end + + +fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success NONE + | SOME s => + let + val env = #envBeforeThisModule s + val decls = #decls s + val loc = #position p + val pp = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 + , character = #character loc + 1} + (* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = 70} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + LspSpec.Success (SOME {contents = res}) + end + end + fun serverLoop () = let val requestMessage = @@ -653,7 +714,7 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + , textDocument_hover = fn ctx => fn p => handleHover state p }) handle LspError e => handleLspErrorInRequest (#id m) e | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 1747d702..9042307a 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -141,10 +141,6 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () - fun getInfo loc = - (Print.print (GetInfo.getInfo loc); - raise Code OS.Process.success) - fun add_class (class, num) = case Int.fromString num of NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") @@ -251,8 +247,6 @@ fun oneRun args = NONE), ("moduleOf", ONE ("", printModuleOf), SOME "print module name of and exit"), - ("getInfo", ONE ("", getInfo), - SOME "print info of expression at and exit"), ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), -- cgit v1.2.3