Mercurial > urweb

comparison src/elaborate.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents f0f59e918cac
children 3739af9e727a
comparison
equal deleted inserted replaced
108:f59553dc1b6a 109:813e5a52063d
1597 | L'.DVal (x, n, t, _) => SOME (L'.SgiVal (x, n, t), loc) 1597 | L'.DVal (x, n, t, _) => SOME (L'.SgiVal (x, n, t), loc)
1598 | L'.DSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, sgn), loc) 1598 | L'.DSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, sgn), loc)
1599 | L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc) 1599 | L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc)
1600 | L'.DFfiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, sgn), loc) 1600 | L'.DFfiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, sgn), loc)
1601 | L'.DConstraint cs => SOME (L'.SgiConstraint cs, loc) 1601 | L'.DConstraint cs => SOME (L'.SgiConstraint cs, loc)
1602 | L'.DPage _ => NONE 1602 | L'.DExport _ => NONE
1603 1603
1604 fun sgiBindsD (env, denv) (sgi, _) = 1604 fun sgiBindsD (env, denv) (sgi, _) =
1605 case sgi of 1605 case sgi of
1606 L'.SgiConstraint (c1, c2) => 1606 L'.SgiConstraint (c1, c2) =>
1607 (case D.assert env denv (c1, c2) of 1607 (case D.assert env denv (c1, c2) of
1927 val denv = dopenConstraints (loc, env, denv) {str = m, strs = ms} 1927 val denv = dopenConstraints (loc, env, denv) {str = m, strs = ms}
1928 in 1928 in
1929 ([], (env, denv, [])) 1929 ([], (env, denv, []))
1930 end 1930 end
1931 1931
1932 | L.DPage e => 1932 | L.DExport str =>
1933 let 1933 let
1934 val basis = 1934 val (str', sgn, gs) = elabStr (env, denv) str
1935 case E.lookupStr env "Basis" of 1935
1936 NONE => raise Fail "elabExp: Unbound Basis" 1936 val sgn =
1937 | SOME (n, _) => n 1937 case #1 (hnormSgn env sgn) of
1938 1938 L'.SgnConst sgis =>
1939 val (e', t, gs1) = elabExp (env, denv) e 1939 let
1940 1940 fun doOne (all as (sgi, _)) =
1941 val k = (L'.KRecord (L'.KType, loc), loc) 1941 case sgi of
1942 val vs = cunif (loc, k) 1942 L'.SgiVal (x, n, t) =>
1943 1943 (case hnormCon (env, denv) t of
1944 val c = (L'.TFun ((L'.TRecord vs, loc), 1944 ((L'.TFun (dom, ran), _), []) =>
1945 (L'.CApp ((L'.CModProj (basis, [], "xml"), loc), 1945 (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of
1946 (L'.CRecord ((L'.KUnit, loc), 1946 (((L'.TRecord domR, _), []),
1947 [((L'.CName "Html", loc), 1947 ((L'.CApp (tf, ranR), _), [])) =>
1948 (L'.CUnit, loc))]), loc)), loc)), loc) 1948 (case hnormCon (env, denv) ranR of
1949 1949 (ranR, []) =>
1950 val gs2 = checkCon (env, denv) e' t c 1950 (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of
1951 in 1951 ((domR, []), (ranR, [])) =>
1952 ([(L'.DPage (vs, e'), loc)], (env, denv, gs1 @ gs2)) 1952 (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc),
1953 (L'.CApp (tf,
1954 (L'.TRecord ranR, loc)), loc)),
1955 loc)), loc)
1956 | _ => all)
1957 | _ => all)
1958 | _ => all)
1959 | _ => all)
1960 | _ => all
1961 in
1962 (L'.SgnConst (map doOne sgis), loc)
1963 end
1964 | _ => sgn
1965 in
1966 ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs))
1953 end 1967 end
1954 1968
1955 and elabStr (env, denv) (str, loc) = 1969 and elabStr (env, denv) (str, loc) =
1956 case str of 1970 case str of
1957 L.StrConst ds => 1971 L.StrConst ds =>