Mercurial > urweb
changeset 1264:79b2bcac6200
Fix bug in module path generation with module roots; push wildification through substructures
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 27 May 2010 10:56:52 -0400 |
| parents | be2ef50780ed |
| children | e8d68fd8ed4b |
| files | src/compiler.sml src/elaborate.sml tests/wildify.ur tests/wildify.urp |
| diffstat | 4 files changed, 204 insertions(+), 89 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sml Sun May 23 11:52:13 2010 -0400 +++ b/src/compiler.sml Thu May 27 10:56:52 2010 -0400 @@ -869,9 +869,13 @@ let val m = (Source.StrVar name, loc) val final = String.extract (final, size root + 1, NONE) + val fields = String.fields (fn ch => ch = #"/") final + val fields = List.filter (fn s => size s = 0 + orelse not (Char.isDigit (String.sub (s, 0)))) + fields in foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc)) - m (String.fields (fn ch => ch = #"/") final) + m fields end val ds = dsFfi @ ds
--- a/src/elaborate.sml Sun May 23 11:52:13 2010 -0400 +++ b/src/elaborate.sml Thu May 27 10:56:52 2010 -0400 @@ -1654,6 +1654,81 @@ findHead e end +datatype needed = Needed of {Cons : (L'.kind * L'.con option) SM.map, + Constraints : (E.env * (L'.con * L'.con) * ErrorMsg.span) list, + Vals : SS.set, + Mods : needed SM.map} + +fun ncons (Needed r) = #Cons r +fun nconstraints (Needed r) = #Constraints r +fun nvals (Needed r) = #Vals r +fun nmods (Needed r) = #Mods r + +val nempty = Needed {Cons = SM.empty, + Constraints = nil, + Vals = SS.empty, + Mods = SM.empty} + +fun naddCon (r : needed, k, v) = + let + val Needed r = r + in + Needed {Cons = SM.insert (#Cons r, k, v), + Constraints = #Constraints r, + Vals = #Vals r, + Mods = #Mods r} + end + +fun naddConstraint (r : needed, v) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + Constraints = v :: #Constraints r, + Vals = #Vals r, + Mods = #Mods r} + end + +fun naddVal (r : needed, k) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + Constraints = #Constraints r, + Vals = SS.add (#Vals r, k), + Mods = #Mods r} + end + +fun naddMod (r : needed, k, v) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + Constraints = #Constraints r, + Vals = #Vals r, + Mods = SM.insert (#Mods r, k, v)} + end + +fun ndelCon (r : needed, k) = + let + val Needed r = r + in + Needed {Cons = #1 (SM.remove (#Cons r, k)) handle NotFound => #Cons r, + Constraints = #Constraints r, + Vals = #Vals r, + Mods = #Mods r} + end + +fun ndelVal (r : needed, k) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + Constraints = #Constraints r, + Vals = SS.delete (#Vals r, k) handle NotFound => #Vals r, + Mods = #Mods r} + end + fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)]*) @@ -3182,96 +3257,106 @@ | _ => NONE - val (neededC, constraints, neededV, _) = - foldl (fn ((sgi, loc), (neededC, constraints, neededV, env')) => - let - val (needed, constraints, neededV) = - case sgi of - L'.SgiCon (x, _, k, c) => (SM.insert (neededC, x, (k, SOME c)), - constraints, neededV) - | L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, (k, NONE)), constraints, neededV) - | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV) - - | L'.SgiVal (x, _, t) => - let - fun default () = (neededC, constraints, neededV) - - val t = normClassConstraint env' t - in - case #1 t of - L'.CApp (f, _) => - if isClassOrFolder env' f then - (neededC, constraints, SS.add (neededV, x)) - else - default () - | _ => default () - end - - | _ => (neededC, constraints, neededV) - in - (needed, constraints, neededV, E.sgiBinds env' (sgi, loc)) - end) - (SM.empty, [], SS.empty, env) sgis - - val (neededC, neededV) = - foldl (fn ((d, _), needed as (neededC, neededV)) => + fun buildNeeded env sgis = + #1 (foldl (fn ((sgi, loc), (nd, env')) => + (case sgi of + L'.SgiCon (x, _, k, c) => naddCon (nd, x, (k, SOME c)) + | L'.SgiConAbs (x, _, k) => naddCon (nd, x, (k, NONE)) + | L'.SgiConstraint cs => naddConstraint (nd, (env', cs, loc)) + | L'.SgiVal (x, _, t) => + let + val t = normClassConstraint env' t + in + case #1 t of + L'.CApp (f, _) => + if isClassOrFolder env' f then + naddVal (nd, x) + else + nd + | _ => nd + end + | L'.SgiStr (x, _, s) => + (case #1 (hnormSgn env s) of + L'.SgnConst sgis' => naddMod (nd, x, buildNeeded env sgis') + | _ => nd) + | _ => nd, + E.sgiBinds env' (sgi, loc))) + (nempty, env) sgis) + + val nd = buildNeeded env sgis + + fun removeUsed (nd, ds) = + foldl (fn ((d, _), nd) => case d of - L.DCon (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) - handle NotFound => - needed) - | L.DClass (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) - handle NotFound => needed) - | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x)) - handle NotFound => needed) - | L.DOpen _ => (SM.empty, SS.empty) - | _ => needed) - (neededC, neededV) ds - - val ds' = List.mapPartial (fn (env', (c1, c2), loc) => - case (decompileCon env' c1, decompileCon env' c2) of - (SOME c1, SOME c2) => - SOME (L.DConstraint (c1, c2), loc) - | _ => NONE) constraints - - val ds' = - case SS.listItems neededV of - [] => ds' - | xs => - let - val ewild = (L.EWild, #2 str) - val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs - in - ds'' @ ds' - end - - val ds' = - case SM.listItemsi neededC of - [] => ds' - | xs => - let - val ds'' = map (fn (x, (k, co)) => - let - val k = - case decompileKind k of - NONE => (L.KWild, #2 str) - | SOME k => k - - val cwild = (L.CWild k, #2 str) - val c = - case co of - NONE => cwild - | SOME c => - case decompileCon env c of - NONE => cwild - | SOME c' => c' - in - (L.DCon (x, NONE, c), #2 str) - end) xs - in - ds'' @ ds' - end + L.DCon (x, _, _) => ndelCon (nd, x) + | L.DClass (x, _, _) => ndelCon (nd, x) + | L.DVal (x, _, _) => ndelVal (nd, x) + | L.DOpen _ => nempty + | L.DStr (x, _, (L.StrConst ds', _)) => + (case SM.find (nmods nd, x) of + NONE => nd + | SOME nd' => naddMod (nd, x, removeUsed (nd', ds'))) + | _ => nd) + nd ds + + val nd = removeUsed (nd, ds) + + fun extend (nd, ds) = + let + val ds' = List.mapPartial (fn (env', (c1, c2), loc) => + case (decompileCon env' c1, decompileCon env' c2) of + (SOME c1, SOME c2) => + SOME (L.DConstraint (c1, c2), loc) + | _ => NONE) (nconstraints nd) + + val ds' = + case SS.listItems (nvals nd) of + [] => ds' + | xs => + let + val ewild = (L.EWild, #2 str) + val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs + in + ds'' @ ds' + end + + val ds' = + case SM.listItemsi (ncons nd) of + [] => ds' + | xs => + let + val ds'' = map (fn (x, (k, co)) => + let + val k = + case decompileKind k of + NONE => (L.KWild, #2 str) + | SOME k => k + + val cwild = (L.CWild k, #2 str) + val c = + case co of + NONE => cwild + | SOME c => + case decompileCon env c of + NONE => cwild + | SOME c' => c' + in + (L.DCon (x, NONE, c), #2 str) + end) xs + in + ds'' @ ds' + end + + val ds = map (fn d as (L.DStr (x, s, (L.StrConst ds', loc')), loc) => + (case SM.find (nmods nd, x) of + NONE => d + | SOME nd' => (L.DStr (x, s, (L.StrConst (extend (nd', ds')), loc')), loc)) + | d => d) ds + in + ds @ ds' + end in - (L.StrConst (ds @ ds'), #2 str) + (L.StrConst (extend (nd, ds)), #2 str) end | _ => str) | _ => str
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/wildify.ur Thu May 27 10:56:52 2010 -0400 @@ -0,0 +1,25 @@ +signature S = sig + type t + val x : t +end + +signature T = sig + structure M : S + + type u + val y : u + + structure N : S +end + +structure M : T = struct + structure M = struct + val x = True + end + + val y = 0 + + structure N = struct + val x = "hi" + end +end