Mercurial > urweb
diff src/elaborate.sml @ 158:b4b70de488e9
More datatype module stuff
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 24 Jul 2008 16:36:41 -0400 |
parents | adc4e42e3adc |
children | 1e382d10e832 |
line wrap: on
line diff
--- a/src/elaborate.sml Thu Jul 24 15:49:30 2008 -0400 +++ b/src/elaborate.sml Thu Jul 24 16:36:41 2008 -0400 @@ -1237,6 +1237,7 @@ | UnOpenable of L'.sgn | NotType of L'.kind * (L'.kind * L'.kind * kunify_error) | DuplicateConstructor of string * ErrorMsg.span + | NotDatatype of ErrorMsg.span fun strError env err = case err of @@ -1258,6 +1259,8 @@ kunifyError ue) | DuplicateConstructor (x, loc) => ErrorMsg.errorAt loc ("Duplicate datatype constructor " ^ x) + | NotDatatype loc => + ErrorMsg.errorAt loc "Trying to import non-datatype as a datatype" val hnormSgn = E.hnormSgn @@ -1319,7 +1322,44 @@ ([(L'.SgiDatatype (x, n, xcs), loc)], (env, denv, gs)) end - | L.SgiDatatypeImp _ => raise Fail "Elaborate SgiDatatypeImp" + | L.SgiDatatypeImp (_, [], _) => raise Fail "Empty SgiDatatypeImp" + + | L.SgiDatatypeImp (x, m1 :: ms, s) => + (case E.lookupStr env m1 of + NONE => (strError env (UnboundStr (loc, m1)); + ([], (env, denv, gs))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case E.projectDatatype env {sgn = sgn, str = str, field = s} of + NONE => (conError env (UnboundDatatype (loc, s)); + ([], (env, denv, gs))) + | SOME xncs => + let + val k = (L'.KType, loc) + val t = (L'.CModProj (n, ms, s), loc) + val (env, n') = E.pushCNamed env x k (SOME t) + val env = E.pushDatatype env n' xncs + + val t = (L'.CNamed n', loc) + val env = foldl (fn ((x, n, to), env) => + let + val t = case to of + NONE => t + | SOME t' => (L'.TFun (t', t), loc) + in + E.pushENamedAs env x n t + end) env xncs + in + ([(L'.SgiDatatypeImp (x, n', n, ms, s), loc)], (env, denv, [])) + end + end) | L.SgiVal (x, c) => let @@ -1501,6 +1541,8 @@ | L'.SgnConst sgis => (L'.SgnConst (map (fn (L'.SgiConAbs (x, n, k), loc) => (L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) + | (L'.SgiDatatype (x, n, xncs), loc) => + (L'.SgiDatatypeImp (x, n, str, strs, x), loc) | (L'.SgiStr (x, n, sgn), loc) => (L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc) | x => x) sgis), #2 sgn) @@ -1745,7 +1787,35 @@ end | _ => NONE) - | L'.SgiDatatypeImp _ => raise Fail "SgiDatatypeImp in subsgn" + | L'.SgiDatatypeImp (x, n2, m11, ms1, s1) => + seek (fn sgi1All as (sgi1, _) => + case sgi1 of + L'.SgiDatatypeImp (x', n1, m12, ms2, s2) => + if x = x' then + let + val k = (L'.KType, loc) + val t1 = (L'.CModProj (m11, ms1, s1), loc) + val t2 = (L'.CModProj (m12, ms2, s2), loc) + + fun good () = + let + val env = E.pushCNamedAs env x n1 k (SOME t1) + val env = E.pushCNamedAs env x n2 k (SOME t2) + in + SOME (env, denv) + end + in + (case unifyCons (env, denv) t1 t2 of + [] => good () + | _ => NONE) + handle CUnify (c1, c2, err) => + (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); + good ()) + end + else + NONE + + | _ => NONE) | L'.SgiVal (x, n2, c2) => seek (fn sgi1All as (sgi1, _) => @@ -1904,28 +1974,32 @@ | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) ms in - case E.projectDatatype env {sgn = sgn, str = str, field = s} of - NONE => (conError env (UnboundDatatype (loc, s)); - ([], (env, denv, gs))) - | SOME xncs => - let - val k = (L'.KType, loc) - val t = (L'.CModProj (n, ms, s), loc) - val (env, n') = E.pushCNamed env x k (SOME t) - val env = E.pushDatatype env n' xncs + case hnormCon (env, denv) (L'.CModProj (n, ms, s), loc) of + ((L'.CModProj (n, ms, s), _), gs) => + (case E.projectDatatype env {sgn = sgn, str = str, field = s} of + NONE => (conError env (UnboundDatatype (loc, s)); + ([], (env, denv, gs))) + | SOME xncs => + let + val k = (L'.KType, loc) + val t = (L'.CModProj (n, ms, s), loc) + val (env, n') = E.pushCNamed env x k (SOME t) + val env = E.pushDatatype env n' xncs - val t = (L'.CNamed n', loc) - val env = foldl (fn ((x, n, to), env) => - let - val t = case to of - NONE => t - | SOME t' => (L'.TFun (t', t), loc) - in - E.pushENamedAs env x n t - end) env xncs - in - ([(L'.DDatatypeImp (x, n', n, ms, s), loc)], (env, denv, [])) - end + val t = (L'.CNamed n', loc) + val env = foldl (fn ((x, n, to), env) => + let + val t = case to of + NONE => t + | SOME t' => (L'.TFun (t', t), loc) + in + E.pushENamedAs env x n t + end) env xncs + in + ([(L'.DDatatypeImp (x, n', n, ms, s), loc)], (env, denv, gs)) + end) + | _ => (strError env (NotDatatype loc); + ([], (env, denv, []))) end) | L.DVal (x, co, e) => @@ -2035,7 +2109,7 @@ val (str', actual, gs2) = elabStr (env, denv) str in - subSgn (env, denv) actual formal; + subSgn (env, denv) (selfifyAt env {str = str', sgn = actual}) formal; (str', formal, gs1 @ gs2) end