Mercurial > urweb
view src/elaborate.sml @ 519:23a88d81a1b5
Optimize CoreUntangle
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 27 Nov 2008 11:40:13 -0500 |
| parents | 685d232bd1a5 |
| children | 44958d74c43f |
line wrap: on
line source
(* Copyright (c) 2008, 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 Elaborate :> ELABORATE = struct structure P = Prim structure L = Source structure L' = Elab structure E = ElabEnv structure U = ElabUtil structure D = Disjoint open Print open ElabPrint open ElabErr structure IM = IntBinaryMap structure SK = struct type ord_key = string val compare = String.compare end structure SS = BinarySetFn(SK) structure SM = BinaryMapFn(SK) val basis_r = ref 0 fun elabExplicitness e = case e of L.Explicit => L'.Explicit | L.Implicit => L'.Implicit fun occursKind r = U.Kind.exists (fn L'.KUnif (_, _, r') => r = r' | _ => false) exception KUnify' of kunify_error fun unifyKinds' (k1All as (k1, _)) (k2All as (k2, _)) = let fun err f = raise KUnify' (f (k1All, k2All)) in case (k1, k2) of (L'.KType, L'.KType) => () | (L'.KUnit, L'.KUnit) => () | (L'.KArrow (d1, r1), L'.KArrow (d2, r2)) => (unifyKinds' d1 d2; unifyKinds' r1 r2) | (L'.KName, L'.KName) => () | (L'.KRecord k1, L'.KRecord k2) => unifyKinds' k1 k2 | (L'.KTuple ks1, L'.KTuple ks2) => ((ListPair.appEq (fn (k1, k2) => unifyKinds' k1 k2) (ks1, ks2)) handle ListPair.UnequalLengths => err KIncompatible) | (L'.KError, _) => () | (_, L'.KError) => () | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' k1All k2All | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' k1All k2All | (L'.KUnif (_, _, r1), L'.KUnif (_, _, r2)) => if r1 = r2 then () else r1 := SOME k2All | (L'.KUnif (_, _, r), _) => if occursKind r k2All then err KOccursCheckFailed else r := SOME k2All | (_, L'.KUnif (_, _, r)) => if occursKind r k1All then err KOccursCheckFailed else r := SOME k1All | _ => err KIncompatible end exception KUnify of L'.kind * L'.kind * kunify_error fun unifyKinds k1 k2 = unifyKinds' k1 k2 handle KUnify' err => raise KUnify (k1, k2, err) fun checkKind env c k1 k2 = unifyKinds k1 k2 handle KUnify (k1, k2, err) => conError env (WrongKind (c, k1, k2, err)) val dummy = ErrorMsg.dummySpan val ktype = (L'.KType, dummy) val kname = (L'.KName, dummy) val ktype_record = (L'.KRecord ktype, dummy) val cerror = (L'.CError, dummy) val kerror = (L'.KError, dummy) val eerror = (L'.EError, dummy) val sgnerror = (L'.SgnError, dummy) val strerror = (L'.StrError, dummy) val int = ref cerror val float = ref cerror val string = ref cerror val table = ref cerror local val count = ref 0 in fun resetKunif () = count := 0 fun kunif loc = let val n = !count val s = if n <= 26 then str (chr (ord #"A" + n)) else "U" ^ Int.toString (n - 26) in count := n + 1; (L'.KUnif (loc, s, ref NONE), dummy) end end local val count = ref 0 in fun resetCunif () = count := 0 fun cunif (loc, k) = let val n = !count val s = if n <= 26 then str (chr (ord #"A" + n)) else "U" ^ Int.toString (n - 26) in count := n + 1; (L'.CUnif (loc, k, s, ref NONE), dummy) end end fun elabKind (k, loc) = case k of L.KType => (L'.KType, loc) | L.KArrow (k1, k2) => (L'.KArrow (elabKind k1, elabKind k2), loc) | L.KName => (L'.KName, loc) | L.KRecord k => (L'.KRecord (elabKind k), loc) | L.KUnit => (L'.KUnit, loc) | L.KTuple ks => (L'.KTuple (map elabKind ks), loc) | L.KWild => kunif loc fun foldKind (dom, ran, loc)= (L'.KArrow ((L'.KArrow ((L'.KName, loc), (L'.KArrow (dom, (L'.KArrow (ran, ran), loc)), loc)), loc), (L'.KArrow (ran, (L'.KArrow ((L'.KRecord dom, loc), ran), loc)), loc)), loc) fun hnormKind (kAll as (k, _)) = case k of L'.KUnif (_, _, ref (SOME k)) => hnormKind k | _ => kAll fun elabCon (env, denv) (c, loc) = case c of L.CAnnot (c, k) => let val k' = elabKind k val (c', ck, gs) = elabCon (env, denv) c in checkKind env c' ck k'; (c', k', gs) end | L.TFun (t1, t2) => let val (t1', k1, gs1) = elabCon (env, denv) t1 val (t2', k2, gs2) = elabCon (env, denv) t2 in checkKind env t1' k1 ktype; checkKind env t2' k2 ktype; ((L'.TFun (t1', t2'), loc), ktype, gs1 @ gs2) end | L.TCFun (e, x, k, t) => let val e' = elabExplicitness e val k' = elabKind k val env' = E.pushCRel env x k' val (t', tk, gs) = elabCon (env', D.enter denv) t in checkKind env t' tk ktype; ((L'.TCFun (e', x, k', t'), loc), ktype, gs) end | L.CDisjoint (c1, c2, c) => let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 val ku1 = kunif loc val ku2 = kunif loc val (denv', gs3) = D.assert env denv (c1', c2') val (c', k, gs4) = elabCon (env, denv') c in checkKind env c1' k1 (L'.KRecord ku1, loc); checkKind env c2' k2 (L'.KRecord ku2, loc); ((L'.CDisjoint (L'.Instantiate, c1', c2', c'), loc), k, gs1 @ gs2 @ gs3 @ gs4) end | L.TRecord c => let val (c', ck, gs) = elabCon (env, denv) c val k = (L'.KRecord ktype, loc) in checkKind env c' ck k; ((L'.TRecord c', loc), ktype, gs) end | L.CVar ([], s) => (case E.lookupC env s of E.NotBound => (conError env (UnboundCon (loc, s)); (cerror, kerror, [])) | E.Rel (n, k) => ((L'.CRel n, loc), k, []) | E.Named (n, k) => ((L'.CNamed n, loc), k, [])) | L.CVar (m1 :: ms, s) => (case E.lookupStr env m1 of NONE => (conError env (UnboundStrInCon (loc, m1)); (cerror, kerror, [])) | 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 val k = case E.projectCon env {sgn = sgn, str = str, field = s} of NONE => (conError env (UnboundCon (loc, s)); kerror) | SOME (k, _) => k in ((L'.CModProj (n, ms, s), loc), k, []) end) | L.CApp (c1, c2) => let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 val dom = kunif loc val ran = kunif loc in checkKind env c1' k1 (L'.KArrow (dom, ran), loc); checkKind env c2' k2 dom; ((L'.CApp (c1', c2'), loc), ran, gs1 @ gs2) end | L.CAbs (x, ko, t) => let val k' = case ko of NONE => kunif loc | SOME k => elabKind k val env' = E.pushCRel env x k' val (t', tk, gs) = elabCon (env', D.enter denv) t in ((L'.CAbs (x, k', t'), loc), (L'.KArrow (k', tk), loc), gs) end | L.CName s => ((L'.CName s, loc), kname, []) | L.CRecord xcs => let val k = kunif loc val (xcs', gs) = ListUtil.foldlMap (fn ((x, c), gs) => let val (x', xk, gs1) = elabCon (env, denv) x val (c', ck, gs2) = elabCon (env, denv) c in checkKind env x' xk kname; checkKind env c' ck k; ((x', c'), gs1 @ gs2 @ gs) end) [] xcs val rc = (L'.CRecord (k, xcs'), loc) (* Add duplicate field checking later. *) fun prove (xcs, ds) = case xcs of [] => ds | xc :: rest => let val r1 = (L'.CRecord (k, [xc]), loc) val ds = foldl (fn (xc', ds) => let val r2 = (L'.CRecord (k, [xc']), loc) in D.prove env denv (r1, r2, loc) @ ds end) ds rest in prove (rest, ds) end in (rc, (L'.KRecord k, loc), prove (xcs', gs)) end | L.CConcat (c1, c2) => let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 val ku = kunif loc val k = (L'.KRecord ku, loc) in checkKind env c1' k1 k; checkKind env c2' k2 k; ((L'.CConcat (c1', c2'), loc), k, D.prove env denv (c1', c2', loc) @ gs1 @ gs2) end | L.CFold => let val dom = kunif loc val ran = kunif loc in ((L'.CFold (dom, ran), loc), foldKind (dom, ran, loc), []) end | L.CUnit => ((L'.CUnit, loc), (L'.KUnit, loc), []) | L.CTuple cs => let val (cs', ks, gs) = foldl (fn (c, (cs', ks, gs)) => let val (c', k, gs') = elabCon (env, denv) c in (c' :: cs', k :: ks, gs' @ gs) end) ([], [], []) cs in ((L'.CTuple (rev cs'), loc), (L'.KTuple (rev ks), loc), gs) end | L.CProj (c, n) => let val (c', k, gs) = elabCon (env, denv) c in case hnormKind k of (L'.KTuple ks, _) => if n <= 0 orelse n > length ks then (conError env (ProjBounds (c', n)); (cerror, kerror, [])) else ((L'.CProj (c', n), loc), List.nth (ks, n - 1), gs) | k => (conError env (ProjMismatch (c', k)); (cerror, kerror, [])) end | L.CWild k => let val k' = elabKind k in (cunif (loc, k'), k', []) end fun kunifsRemain k = case k of L'.KUnif (_, _, ref NONE) => true | _ => false fun cunifsRemain c = case c of L'.CUnif (loc, _, _, ref NONE) => SOME loc | _ => NONE val kunifsInDecl = U.Decl.exists {kind = kunifsRemain, con = fn _ => false, exp = fn _ => false, sgn_item = fn _ => false, sgn = fn _ => false, str = fn _ => false, decl = fn _ => false} val cunifsInDecl = U.Decl.search {kind = fn _ => NONE, con = cunifsRemain, exp = fn _ => NONE, sgn_item = fn _ => NONE, sgn = fn _ => NONE, str = fn _ => NONE, decl = fn _ => NONE} fun occursCon r = U.Con.exists {kind = fn _ => false, con = fn L'.CUnif (_, _, _, r') => r = r' | _ => false} exception CUnify' of cunify_error exception SynUnif = E.SynUnif open ElabOps type record_summary = { fields : (L'.con * L'.con) list, unifs : (L'.con * L'.con option ref) list, others : L'.con list } fun summaryToCon {fields, unifs, others} = let val c = (L'.CRecord (ktype, []), dummy) val c = List.foldr (fn (c', c) => (L'.CConcat (c', c), dummy)) c others val c = List.foldr (fn ((c', _), c) => (L'.CConcat (c', c), dummy)) c unifs in (L'.CConcat ((L'.CRecord (ktype, fields), dummy), c), dummy) end fun p_summary env s = p_con env (summaryToCon s) exception CUnify of L'.con * L'.con * cunify_error fun kindof env (c, loc) = case c of L'.TFun _ => ktype | L'.TCFun _ => ktype | L'.TRecord _ => ktype | L'.CRel xn => #2 (E.lookupCRel env xn) | L'.CNamed xn => #2 (E.lookupCNamed env xn) | L'.CModProj (n, ms, x) => let val (_, sgn) = E.lookupStrNamed env n val (str, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {sgn = sgn, str = str, field = m} of NONE => raise Fail "kindof: Unknown substructure" | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) ms in case E.projectCon env {sgn = sgn, str = str, field = x} of NONE => raise Fail "kindof: Unknown con in structure" | SOME (k, _) => k end | L'.CApp (c, _) => (case hnormKind (kindof env c) of (L'.KArrow (_, k), _) => k | (L'.KError, _) => kerror | k => raise CUnify' (CKindof (k, c, "arrow"))) | L'.CAbs (x, k, c) => (L'.KArrow (k, kindof (E.pushCRel env x k) c), loc) | L'.CDisjoint (_, _, _, c) => kindof env c | L'.CName _ => kname | L'.CRecord (k, _) => (L'.KRecord k, loc) | L'.CConcat (c, _) => kindof env c | L'.CFold (dom, ran) => foldKind (dom, ran, loc) | L'.CUnit => (L'.KUnit, loc) | L'.CTuple cs => (L'.KTuple (map (kindof env) cs), loc) | L'.CProj (c, n) => (case hnormKind (kindof env c) of (L'.KTuple ks, _) => List.nth (ks, n - 1) | k => raise CUnify' (CKindof (k, c, "tuple"))) | L'.CError => kerror | L'.CUnif (_, k, _, _) => k val hnormCon = D.hnormCon datatype con_summary = Nil | Cons | Unknown fun compatible cs = case cs of (Unknown, _) => false | (_, Unknown) => false | (s1, s2) => s1 = s2 fun summarizeCon (env, denv) c = let val (c, gs) = hnormCon (env, denv) c in case #1 c of L'.CRecord (_, []) => (Nil, gs) | L'.CRecord (_, _ :: _) => (Cons, gs) | L'.CConcat ((L'.CRecord (_, _ :: _), _), _) => (Cons, gs) | L'.CDisjoint (_, _, _, c) => let val (s, gs') = summarizeCon (env, denv) c in (s, gs @ gs') end | _ => (Unknown, gs) end fun p_con_summary s = Print.PD.string (case s of Nil => "Nil" | Cons => "Cons" | Unknown => "Unknown") exception SummaryFailure fun isUnitCon env (c, loc) = case c of L'.TFun _ => false | L'.TCFun _ => false | L'.TRecord _ => false | L'.CRel xn => #1 (#2 (E.lookupCRel env xn)) = L'.KUnit | L'.CNamed xn => #1 (#2 (E.lookupCNamed env xn)) = L'.KUnit | L'.CModProj (n, ms, x) => false (*let val (_, sgn) = E.lookupStrNamed env n val (str, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {sgn = sgn, str = str, field = m} of NONE => raise Fail "kindof: Unknown substructure" | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) ms in case E.projectCon env {sgn = sgn, str = str, field = x} of NONE => raise Fail "kindof: Unknown con in structure" | SOME ((k, _), _) => k = L'.KUnit end*) | L'.CApp (c, _) => false (*(case hnormKind (kindof env c) of (L'.KArrow (_, k), _) => #1 k = L'.KUnit | (L'.KError, _) => false | k => raise CUnify' (CKindof (k, c, "arrow")))*) | L'.CAbs _ => false | L'.CDisjoint (_, _, _, c) => false(*isUnitCon env c*) | L'.CName _ => false | L'.CRecord _ => false | L'.CConcat _ => false | L'.CFold _ => false | L'.CUnit => true | L'.CTuple _ => false | L'.CProj (c, n) => false (*(case hnormKind (kindof env c) of (L'.KTuple ks, _) => #1 (List.nth (ks, n - 1)) = L'.KUnit | k => raise CUnify' (CKindof (k, c, "tuple")))*) | L'.CError => false | L'.CUnif (_, k, _, _) => #1 k = L'.KUnit fun unifyRecordCons (env, denv) (c1, c2) = let fun rkindof c = case hnormKind (kindof env c) of (L'.KRecord k, _) => k | (L'.KError, _) => kerror | k => raise CUnify' (CKindof (k, c, "record")) val k1 = rkindof c1 val k2 = rkindof c2 val (r1, gs1) = recordSummary (env, denv) c1 val (r2, gs2) = recordSummary (env, denv) c2 in unifyKinds k1 k2; unifySummaries (env, denv) (k1, r1, r2); gs1 @ gs2 end and recordSummary (env, denv) c = let val (c, gs) = hnormCon (env, denv) c val (sum, gs') = case c of (L'.CRecord (_, xcs), _) => ({fields = xcs, unifs = [], others = []}, []) | (L'.CConcat (c1, c2), _) => let val (s1, gs1) = recordSummary (env, denv) c1 val (s2, gs2) = recordSummary (env, denv) c2 in ({fields = #fields s1 @ #fields s2, unifs = #unifs s1 @ #unifs s2, others = #others s1 @ #others s2}, gs1 @ gs2) end | (L'.CUnif (_, _, _, ref (SOME c)), _) => recordSummary (env, denv) c | c' as (L'.CUnif (_, _, _, r), _) => ({fields = [], unifs = [(c', r)], others = []}, []) | c' => ({fields = [], unifs = [], others = [c']}, []) in (sum, gs @ gs') end and consEq (env, denv) (c1, c2) = let val gs = unifyCons (env, denv) c1 c2 in List.all (fn (loc, env, denv, c1, c2) => case D.prove env denv (c1, c2, loc) of [] => true | _ => false) gs end handle CUnify _ => false and consNeq env (c1, c2) = case (#1 (ElabOps.hnormCon env c1), #1 (ElabOps.hnormCon env c2)) of (L'.CName x1, L'.CName x2) => x1 <> x2 | _ => false and unifySummaries (env, denv) (k, s1 : record_summary, s2 : record_summary) = let val loc = #2 k (*val () = eprefaces "Summaries" [("#1", p_summary env s1), ("#2", p_summary env s2)]*) fun eatMatching p (ls1, ls2) = let fun em (ls1, ls2, passed1) = case ls1 of [] => (rev passed1, ls2) | h1 :: t1 => let fun search (ls2', passed2) = case ls2' of [] => em (t1, ls2, h1 :: passed1) | h2 :: t2 => if p (h1, h2) then em (t1, List.revAppend (passed2, t2), passed1) else search (t2, h2 :: passed2) in search (ls2, []) end in em (ls1, ls2, []) end val (fs1, fs2) = eatMatching (fn ((x1, c1), (x2, c2)) => not (consNeq env (x1, x2)) andalso consEq (env, denv) (c1, c2) andalso consEq (env, denv) (x1, x2)) (#fields s1, #fields s2) (*val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}), ("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})]*) val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (#unifs s1, #unifs s2) val (others1, others2) = eatMatching (consEq (env, denv)) (#others s1, #others s2) (*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) fun unifFields (fs, others, unifs) = case (fs, others, unifs) of ([], [], _) => ([], [], unifs) | (_, _, []) => (fs, others, []) | (_, _, (_, r) :: rest) => let val r' = ref NONE val kr = (L'.KRecord k, dummy) val cr' = (L'.CUnif (dummy, kr, "recd", r'), dummy) val prefix = case (fs, others) of ([], other :: others) => List.foldl (fn (other, c) => (L'.CConcat (c, other), dummy)) other others | (fs, []) => (L'.CRecord (k, fs), dummy) | (fs, others) => List.foldl (fn (other, c) => (L'.CConcat (c, other), dummy)) (L'.CRecord (k, fs), dummy) others in r := SOME (L'.CConcat (prefix, cr'), dummy); ([], [], (cr', r') :: rest) end val (fs1, others1, unifs2) = unifFields (fs1, others1, unifs2) val (fs2, others2, unifs1) = unifFields (fs2, others2, unifs1) (*val () = eprefaces "Summaries4" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) fun isGuessable (other, fs) = let val gs = guessFold (env, denv) (other, (L'.CRecord (k, fs), loc), [], SummaryFailure) in List.all (fn (loc, env, denv, c1, c2) => case D.prove env denv (c1, c2, loc) of [] => true | _ => false) gs end handle SummaryFailure => false val (fs1, fs2, others1, others2) = case (fs1, fs2, others1, others2) of ([], _, [other1], []) => if isGuessable (other1, fs2) then ([], [], [], []) else (fs1, fs2, others1, others2) | (_, [], [], [other2]) => if isGuessable (other2, fs1) then ([], [], [], []) else (fs1, fs2, others1, others2) | _ => (fs1, fs2, others1, others2) (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) val clear = case (fs1, others1, fs2, others2) of ([], [], [], []) => true | _ => false val empty = (L'.CRecord (k, []), dummy) fun unsummarize {fields, unifs, others} = let val c = (L'.CRecord (k, fields), loc) val c = foldl (fn ((c1, _), c2) => (L'.CConcat (c1, c2), loc)) c unifs in foldl (fn (c1, c2) => (L'.CConcat (c1, c2), loc)) c others end fun pairOffUnifs (unifs1, unifs2) = case (unifs1, unifs2) of ([], _) => if clear then List.app (fn (_, r) => r := SOME empty) unifs2 else raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2)) | (_, []) => if clear then List.app (fn (_, r) => r := SOME empty) unifs1 else raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2)) | ((c1, _) :: rest1, (_, r2) :: rest2) => (r2 := SOME c1; pairOffUnifs (rest1, rest2)) in pairOffUnifs (unifs1, unifs2) (*before eprefaces "Summaries'" [("#1", p_summary env s1), ("#2", p_summary env s2)]*) end and guessFold (env, denv) (c1, c2, gs, ex) = let val loc = #2 c1 fun unfold (dom, ran, f, i, r, c) = let val nm = cunif (loc, (L'.KName, loc)) val v = case dom of (L'.KUnit, _) => (L'.CUnit, loc) | _ => cunif (loc, dom) val rest = cunif (loc, (L'.KRecord dom, loc)) val acc = (L'.CFold (dom, ran), loc) val acc = (L'.CApp (acc, f), loc) val acc = (L'.CApp (acc, i), loc) val acc = (L'.CApp (acc, rest), loc) val (iS, gs3) = summarizeCon (env, denv) i val app = (L'.CApp (f, nm), loc) val app = (L'.CApp (app, v), loc) val app = (L'.CApp (app, acc), loc) val (appS, gs4) = summarizeCon (env, denv) app val (cS, gs5) = summarizeCon (env, denv) c in (*prefaces "Summaries" [("iS", p_con_summary iS), ("appS", p_con_summary appS), ("cS", p_con_summary cS)];*) if compatible (iS, appS) then raise ex else if compatible (cS, iS) then let (*val () = prefaces "Same?" [("i", p_con env i), ("c", p_con env c)]*) val gs6 = unifyCons (env, denv) i c (*val () = TextIO.print "Yes!\n"*) val gs7 = unifyCons (env, denv) r (L'.CRecord (dom, []), loc) in gs @ gs3 @ gs5 @ gs6 @ gs7 end else if compatible (cS, appS) then let (*val () = prefaces "Same?" [("app", p_con env app), ("c", p_con env c), ("app'", p_con env (#1 (hnormCon (env, denv) app)))]*) val gs6 = unifyCons (env, denv) app c (*val () = TextIO.print "Yes!\n"*) val singleton = (L'.CRecord (dom, [(nm, v)]), loc) val concat = (L'.CConcat (singleton, rest), loc) (*val () = prefaces "Pre-crew" [("r", p_con env r), ("concat", p_con env concat)]*) val gs7 = unifyCons (env, denv) r concat in (*prefaces "The crew" [("nm", p_con env nm), ("v", p_con env v), ("rest", p_con env rest)];*) gs @ gs3 @ gs4 @ gs5 @ gs6 @ gs7 end else raise ex end handle _ => raise ex in case (#1 c1, #1 c2) of (L'.CApp ((L'.CApp ((L'.CApp ((L'.CFold (dom, ran), _), f), _), i), _), r), _) => unfold (dom, ran, f, i, r, c2) | (_, L'.CApp ((L'.CApp ((L'.CApp ((L'.CFold (dom, ran), _), f), _), i), _), r)) => unfold (dom, ran, f, i, r, c1) | _ => raise ex end and unifyCons' (env, denv) c1 c2 = case (#1 c1, #1 c2) of (L'.CDisjoint (_, x1, y1, t1), L'.CDisjoint (_, x2, y2, t2)) => let val gs1 = unifyCons' (env, denv) x1 x2 val gs2 = unifyCons' (env, denv) y1 y2 val (denv', gs3) = D.assert env denv (x1, y1) val gs4 = unifyCons' (env, denv') t1 t2 in gs1 @ gs2 @ gs3 @ gs4 end | _ => if isUnitCon env c1 andalso isUnitCon env c2 then [] else let (*val befor = Time.now () val old1 = c1 val old2 = c2*) val (c1, gs1) = hnormCon (env, denv) c1 val (c2, gs2) = hnormCon (env, denv) c2 in let val gs3 = unifyCons'' (env, denv) c1 c2 in (*prefaces "unifyCons'" [("c1", p_con env old1), ("c2", p_con env old2), ("t", PD.string (LargeReal.toString (Time.toReal (Time.- (Time.now (), befor)))))];*) gs1 @ gs2 @ gs3 end handle ex => guessFold (env, denv) (c1, c2, gs1 @ gs2, ex) end and unifyCons'' (env, denv) (c1All as (c1, loc)) (c2All as (c2, _)) = let fun err f = raise CUnify' (f (c1All, c2All)) fun isRecord () = unifyRecordCons (env, denv) (c1All, c2All) in (*eprefaces "unifyCons''" [("c1All", p_con env c1All), ("c2All", p_con env c2All)];*) case (c1, c2) of (L'.CUnit, L'.CUnit) => [] | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => unifyCons' (env, denv) d1 d2 @ unifyCons' (env, denv) r1 r2 | (L'.TCFun (expl1, x1, d1, r1), L'.TCFun (expl2, _, d2, r2)) => if expl1 <> expl2 then err CExplicitness else (unifyKinds d1 d2; let val denv' = D.enter denv (*val befor = Time.now ()*) val env' = E.pushCRel env x1 d1 in (*TextIO.print ("E.pushCRel: " ^ LargeReal.toString (Time.toReal (Time.- (Time.now (), befor))) ^ "\n");*) unifyCons' (env', denv') r1 r2 end) | (L'.TRecord r1, L'.TRecord r2) => unifyCons' (env, denv) r1 r2 | (L'.CRel n1, L'.CRel n2) => if n1 = n2 then [] else err CIncompatible | (L'.CNamed n1, L'.CNamed n2) => if n1 = n2 then [] else err CIncompatible | (L'.CApp (d1, r1), L'.CApp (d2, r2)) => (unifyCons' (env, denv) d1 d2; unifyCons' (env, denv) r1 r2) | (L'.CAbs (x1, k1, c1), L'.CAbs (_, k2, c2)) => (unifyKinds k1 k2; unifyCons' (E.pushCRel env x1 k1, D.enter denv) c1 c2) | (L'.CName n1, L'.CName n2) => if n1 = n2 then [] else err CIncompatible | (L'.CModProj (n1, ms1, x1), L'.CModProj (n2, ms2, x2)) => if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then [] else err CIncompatible | (L'.CTuple cs1, L'.CTuple cs2) => ((ListPair.foldlEq (fn (c1, c2, gs) => let val gs' = unifyCons' (env, denv) c1 c2 in gs' @ gs end) [] (cs1, cs2)) handle ListPair.UnequalLengths => err CIncompatible) | (L'.CProj ((L'.CUnif (_, _, _, ref (SOME c1)), loc), n1), _) => unifyCons' (env, denv) (L'.CProj (c1, n1), loc) c2All | (_, L'.CProj ((L'.CUnif (_, _, _, ref (SOME c2)), loc), n2)) => unifyCons' (env, denv) c1All (L'.CProj (c2, n2), loc) | (L'.CProj ((L'.CUnif (_, (L'.KTuple ks, _), _, r), loc), n), _) => let val us = map (fn k => cunif (loc, k)) ks in r := SOME (L'.CTuple us, loc); unifyCons' (env, denv) (List.nth (us, n - 1)) c2All end | (_, L'.CProj ((L'.CUnif (_, (L'.KTuple ks, _), _, r), loc), n)) => let val us = map (fn k => cunif (loc, k)) ks in r := SOME (L'.CTuple us, loc); unifyCons' (env, denv) c1All (List.nth (us, n - 1)) end | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => if n1 = n2 then unifyCons' (env, denv) c1 c2 else err CIncompatible | (L'.CError, _) => [] | (_, L'.CError) => [] | (L'.CRecord _, _) => isRecord () | (_, L'.CRecord _) => isRecord () | (L'.CConcat _, _) => isRecord () | (_, L'.CConcat _) => isRecord () | (L'.CUnif (_, k1, _, r1), L'.CUnif (_, k2, _, r2)) => if r1 = r2 then [] else (unifyKinds k1 k2; r1 := SOME c2All; []) | (L'.CUnif (_, _, _, r), _) => if occursCon r c2All then err COccursCheckFailed else (r := SOME c2All; []) | (_, L'.CUnif (_, _, _, r)) => if occursCon r c1All then err COccursCheckFailed else (r := SOME c1All; []) | (L'.CFold (dom1, ran1), L'.CFold (dom2, ran2)) => (unifyKinds dom1 dom2; unifyKinds ran1 ran2; []) | _ => err CIncompatible end and unifyCons (env, denv) c1 c2 = unifyCons' (env, denv) c1 c2 handle CUnify' err => raise CUnify (c1, c2, err) | KUnify args => raise CUnify (c1, c2, CKind args) fun checkCon (env, denv) e c1 c2 = unifyCons (env, denv) c1 c2 handle CUnify (c1, c2, err) => (expError env (Unify (e, c1, c2, err)); []) fun checkPatCon (env, denv) p c1 c2 = unifyCons (env, denv) c1 c2 handle CUnify (c1, c2, err) => (expError env (PatUnify (p, c1, c2, err)); []) fun primType env p = case p of P.Int _ => !int | P.Float _ => !float | P.String _ => !string fun recCons (k, nm, v, rest, loc) = (L'.CConcat ((L'.CRecord (k, [(nm, v)]), loc), rest), loc) fun foldType (dom, loc) = (L'.TCFun (L'.Explicit, "ran", (L'.KArrow ((L'.KRecord dom, loc), (L'.KType, loc)), loc), (L'.TFun ((L'.TCFun (L'.Explicit, "nm", (L'.KName, loc), (L'.TCFun (L'.Explicit, "v", dom, (L'.TCFun (L'.Explicit, "rest", (L'.KRecord dom, loc), (L'.TFun ((L'.CApp ((L'.CRel 3, loc), (L'.CRel 0, loc)), loc), (L'.CDisjoint (L'.Instantiate, (L'.CRecord ((L'.KUnit, loc), [((L'.CRel 2, loc), (L'.CUnit, loc))]), loc), (L'.CRel 0, loc), (L'.CApp ((L'.CRel 3, loc), recCons (dom, (L'.CRel 2, loc), (L'.CRel 1, loc), (L'.CRel 0, loc), loc)), loc)), loc)), loc)), loc)), loc)), loc), (L'.TFun ((L'.CApp ((L'.CRel 0, loc), (L'.CRecord (dom, []), loc)), loc), (L'.TCFun (L'.Explicit, "r", (L'.KRecord dom, loc), (L'.CApp ((L'.CRel 1, loc), (L'.CRel 0, loc)), loc)), loc)), loc)), loc)), loc) datatype constraint = Disjoint of D.goal | TypeClass of E.env * L'.con * L'.exp option ref * ErrorMsg.span val enD = map Disjoint fun elabHead (env, denv) infer (e as (_, loc)) t = let fun unravel (t, e) = let val (t, gs) = hnormCon (env, denv) t in case t of (L'.TCFun (L'.Implicit, x, k, t'), _) => let val u = cunif (loc, k) val t'' = subConInCon (0, u) t' val (e, t, gs') = unravel (t'', (L'.ECApp (e, u), loc)) in (*prefaces "Unravel" [("t'", p_con env t'), ("t''", p_con env t'')];*) (e, t, enD gs @ gs') end | (L'.TFun (dom as (L'.CApp (cl, _), _), ran), _) => let val cl = #1 (hnormCon (env, denv) cl) in if infer <> L.TypesOnly andalso E.isClass env cl then let val r = ref NONE val (e, t, gs') = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc)) in (e, t, TypeClass (env, dom, r, loc) :: enD gs @ gs') end else (e, t, enD gs) end | _ => (e, t, enD gs) end in case infer of L.DontInfer => (e, t, []) | _ => unravel (t, e) end fun elabPat (pAll as (p, loc), (env, denv, bound)) = let val perror = (L'.PWild, loc) val terror = (L'.CError, loc) val pterror = (perror, terror) val rerror = (pterror, (env, bound)) fun pcon (pc, po, xs, to, dn, dk) = case (po, to) of (NONE, SOME _) => (expError env (PatHasNoArg loc); rerror) | (SOME _, NONE) => (expError env (PatHasArg loc); rerror) | (NONE, NONE) => let val k = (L'.KType, loc) val unifs = map (fn _ => cunif (loc, k)) xs val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs in (((L'.PCon (dk, pc, unifs, NONE), loc), dn), (env, bound)) end | (SOME p, SOME t) => let val ((p', pt), (env, bound)) = elabPat (p, (env, denv, bound)) val k = (L'.KType, loc) val unifs = map (fn _ => cunif (loc, k)) xs val nxs = length unifs - 1 val t = ListUtil.foldli (fn (i, u, t) => subConInCon (nxs - i, u) t) t unifs val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs in ignore (checkPatCon (env, denv) p' pt t); (((L'.PCon (dk, pc, unifs, SOME p'), loc), dn), (env, bound)) end in case p of L.PWild => (((L'.PWild, loc), cunif (loc, (L'.KType, loc))), (env, bound)) | L.PVar x => let val t = if SS.member (bound, x) then (expError env (DuplicatePatternVariable (loc, x)); terror) else cunif (loc, (L'.KType, loc)) in (((L'.PVar (x, t), loc), t), (E.pushERel env x t, SS.add (bound, x))) end | L.PPrim p => (((L'.PPrim p, loc), primType env p), (env, bound)) | L.PCon ([], x, po) => (case E.lookupConstructor env x of NONE => (expError env (UnboundConstructor (loc, [], x)); rerror) | SOME (dk, n, xs, to, dn) => pcon (L'.PConVar n, po, xs, to, (L'.CNamed dn, loc), dk)) | L.PCon (m1 :: ms, x, po) => (case E.lookupStr env m1 of NONE => (expError env (UnboundStrInExp (loc, m1)); rerror) | SOME (n, sgn) => let val (str, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {sgn = sgn, str = str, field = m} of NONE => raise Fail "elabPat: Unknown substructure" | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) ms in case E.projectConstructor env {str = str, sgn = sgn, field = x} of NONE => (expError env (UnboundConstructor (loc, m1 :: ms, x)); rerror) | SOME (dk, _, xs, to, dn) => pcon (L'.PConProj (n, ms, x), po, xs, to, dn, dk) end) | L.PRecord (xps, flex) => let val (xpts, (env, bound, _)) = ListUtil.foldlMap (fn ((x, p), (env, bound, fbound)) => let val ((p', t), (env, bound)) = elabPat (p, (env, denv, bound)) in if SS.member (fbound, x) then expError env (DuplicatePatField (loc, x)) else (); ((x, p', t), (env, bound, SS.add (fbound, x))) end) (env, bound, SS.empty) xps val k = (L'.KType, loc) val c = (L'.CRecord (k, map (fn (x, _, t) => ((L'.CName x, loc), t)) xpts), loc) val c = if flex then (L'.CConcat (c, cunif (loc, (L'.KRecord k, loc))), loc) else c in (((L'.PRecord xpts, loc), (L'.TRecord c, loc)), (env, bound)) end end datatype coverage = Wild | None | Datatype of coverage IM.map | Record of coverage SM.map list fun c2s c = case c of Wild => "Wild" | None => "None" | Datatype _ => "Datatype" | Record _ => "Record" fun exhaustive (env, denv, t, ps) = let fun depth (p, _) = case p of L'.PWild => 0 | L'.PVar _ => 0 | L'.PPrim _ => 0 | L'.PCon (_, _, _, NONE) => 1 | L'.PCon (_, _, _, SOME p) => 1 + depth p | L'.PRecord xps => foldl (fn ((_, p, _), n) => Int.max (depth p, n)) 0 xps val depth = 1 + foldl (fn (p, n) => Int.max (depth p, n)) 0 ps fun pcCoverage pc = case pc of L'.PConVar n => n | L'.PConProj (m1, ms, x) => let val (str, sgn) = E.chaseMpath env (m1, ms) in case E.projectConstructor env {str = str, sgn = sgn, field = x} of NONE => raise Fail "exhaustive: Can't project constructor" | SOME (_, n, _, _, _) => n end fun coverage (p, _) = case p of L'.PWild => Wild | L'.PVar _ => Wild | L'.PPrim _ => None | L'.PCon (_, pc, _, NONE) => Datatype (IM.insert (IM.empty, pcCoverage pc, Wild)) | L'.PCon (_, pc, _, SOME p) => Datatype (IM.insert (IM.empty, pcCoverage pc, coverage p)) | L'.PRecord xps => Record [foldl (fn ((x, p, _), fmap) => SM.insert (fmap, x, coverage p)) SM.empty xps] fun merge (c1, c2) = case (c1, c2) of (None, _) => c2 | (_, None) => c1 | (Wild, _) => Wild | (_, Wild) => Wild | (Datatype cm1, Datatype cm2) => Datatype (IM.unionWith merge (cm1, cm2)) | (Record fm1, Record fm2) => Record (fm1 @ fm2) | _ => None fun combinedCoverage ps = case ps of [] => raise Fail "Empty pattern list for coverage checking" | [p] => coverage p | p :: ps => merge (coverage p, combinedCoverage ps) fun enumerateCases depth t = if depth = 0 then [Wild] else let fun dtype cons = ListUtil.mapConcat (fn (_, n, to) => case to of NONE => [Datatype (IM.insert (IM.empty, n, Wild))] | SOME t => map (fn c => Datatype (IM.insert (IM.empty, n, c))) (enumerateCases (depth-1) t)) cons in case #1 (#1 (hnormCon (env, denv) t)) of L'.CNamed n => (let val dt = E.lookupDatatype env n val cons = E.constructors dt in dtype cons end handle E.UnboundNamed _ => [Wild]) | L'.TRecord c => (case #1 (#1 (hnormCon (env, denv) c)) of L'.CRecord (_, xts) => let val xts = map (fn (x, t) => (#1 (hnormCon (env, denv) x), t)) xts fun exponentiate fs = case fs of [] => [SM.empty] | ((L'.CName x, _), t) :: rest => let val this = enumerateCases depth t val rest = exponentiate rest in ListUtil.mapConcat (fn fmap => map (fn c => SM.insert (fmap, x, c)) this) rest end | _ => raise Fail "exponentiate: Not CName" in if List.exists (fn ((L'.CName _, _), _) => false | (c, _) => true) xts then [Wild] else map (fn ls => Record [ls]) (exponentiate xts) end | _ => [Wild]) | _ => [Wild] end fun coverageImp (c1, c2) = let val r = case (c1, c2) of (Wild, _) => true | (Datatype cmap1, Datatype cmap2) => List.all (fn (n, c2) => case IM.find (cmap1, n) of NONE => false | SOME c1 => coverageImp (c1, c2)) (IM.listItemsi cmap2) | (Datatype cmap1, Wild) => List.all (fn (n, c1) => coverageImp (c1, Wild)) (IM.listItemsi cmap1) | (Record fmaps1, Record fmaps2) => List.all (fn fmap2 => List.exists (fn fmap1 => List.all (fn (x, c2) => case SM.find (fmap1, x) of NONE => true | SOME c1 => coverageImp (c1, c2)) (SM.listItemsi fmap2)) fmaps1) fmaps2 | (Record fmaps1, Wild) => List.exists (fn fmap1 => List.all (fn (x, c1) => coverageImp (c1, Wild)) (SM.listItemsi fmap1)) fmaps1 | _ => false in (*TextIO.print ("coverageImp(" ^ c2s c1 ^ ", " ^ c2s c2 ^ ") = " ^ Bool.toString r ^ "\n");*) r end fun isTotal (c, t) = case c of None => (false, []) | Wild => (true, []) | Datatype cm => let val ((t, _), gs) = hnormCon (env, denv) t fun dtype cons = foldl (fn ((_, n, to), (total, gs)) => case IM.find (cm, n) of NONE => (false, gs) | SOME c' => case to of NONE => (total, gs) | SOME t' => let val (total, gs') = isTotal (c', t') in (total, gs' @ gs) end) (true, gs) cons fun unapp t = case t of L'.CApp ((t, _), _) => unapp t | _ => t in case unapp t of L'.CNamed n => let val dt = E.lookupDatatype env n val cons = E.constructors dt in dtype cons end | L'.CModProj (m1, ms, x) => let val (str, sgn) = E.chaseMpath env (m1, ms) in case E.projectDatatype env {str = str, sgn = sgn, field = x} of NONE => raise Fail "isTotal: Can't project datatype" | SOME (_, cons) => dtype cons end | L'.CError => (true, gs) | c => (prefaces "Not a datatype" [("c", p_con env (c, ErrorMsg.dummySpan))]; raise Fail "isTotal: Not a datatype") end | Record _ => (List.all (fn c2 => coverageImp (c, c2)) (enumerateCases depth t), []) in isTotal (combinedCoverage ps, t) end fun unmodCon env (c, loc) = case c of L'.CNamed n => (case E.lookupCNamed env n of (_, _, SOME (c as (L'.CModProj _, _))) => unmodCon env c | _ => (c, loc)) | L'.CModProj (m1, ms, x) => let val (str, sgn) = E.chaseMpath env (m1, ms) in case E.projectCon env {str = str, sgn = sgn, field = x} of NONE => raise Fail "unmodCon: Can't projectCon" | SOME (_, SOME (c as (L'.CModProj _, _))) => unmodCon env c | _ => (c, loc) end | _ => (c, loc) fun normClassKey envs c = let val c = ElabOps.hnormCon envs c in case #1 c of L'.CApp (c1, c2) => let val c1 = normClassKey envs c1 val c2 = normClassKey envs c2 in (L'.CApp (c1, c2), #2 c) end | _ => c end fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let val f = unmodCon env f val x = normClassKey env x in (L'.CApp (f, x), loc) end | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c | _ => (c, loc) val makeInstantiable = let fun kind k = k fun con c = case c of L'.CDisjoint (L'.LeaveAlone, c1, c2, c) => L'.CDisjoint (L'.Instantiate, c1, c2, c) | _ => c in U.Con.map {kind = kind, con = con} end fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) (*val befor = Time.now ()*) val r = case e of L.EAnnot (e, t) => let val (e', et, gs1) = elabExp (env, denv) e val (t', _, gs2) = elabCon (env, denv) t val gs3 = checkCon (env, denv) e' et t' in (e', t', gs1 @ enD gs2 @ enD gs3) end | L.EPrim p => ((L'.EPrim p, loc), primType env p, []) | L.EVar ([], s, infer) => (case E.lookupE env s of E.NotBound => (expError env (UnboundExp (loc, s)); (eerror, cerror, [])) | E.Rel (n, t) => elabHead (env, denv) infer (L'.ERel n, loc) t | E.Named (n, t) => elabHead (env, denv) infer (L'.ENamed n, loc) t) | L.EVar (m1 :: ms, s, infer) => (case E.lookupStr env m1 of NONE => (expError env (UnboundStrInExp (loc, m1)); (eerror, cerror, [])) | 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 val t = case E.projectVal env {sgn = sgn, str = str, field = s} of NONE => (expError env (UnboundExp (loc, s)); cerror) | SOME t => t in elabHead (env, denv) infer (L'.EModProj (n, ms, s), loc) t end) | L.EWild => let val r = ref NONE val c = cunif (loc, (L'.KType, loc)) in ((L'.EUnif r, loc), c, [TypeClass (env, c, r, loc)]) end | L.EApp (e1, e2) => let val (e1', t1, gs1) = elabExp (env, denv) e1 val (e2', t2, gs2) = elabExp (env, denv) e2 val dom = cunif (loc, ktype) val ran = cunif (loc, ktype) val t = (L'.TFun (dom, ran), dummy) val gs3 = checkCon (env, denv) e1' t1 t val gs4 = checkCon (env, denv) e2' t2 dom val gs = gs1 @ gs2 @ enD gs3 @ enD gs4 in ((L'.EApp (e1', e2'), loc), ran, gs) end | L.EAbs (x, to, e) => let val (t', gs1) = case to of NONE => (cunif (loc, ktype), []) | SOME t => let val (t', tk, gs) = elabCon (env, denv) t in checkKind env t' tk ktype; (t', gs) end val dom = normClassConstraint env t' val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e in ((L'.EAbs (x, t', et, e'), loc), (L'.TFun (t', et), loc), enD gs1 @ gs2) end | L.ECApp (e, c) => let val (e', et, gs1) = elabExp (env, denv) e val oldEt = et val (c', ck, gs2) = elabCon (env, denv) c val ((et', _), gs3) = hnormCon (env, denv) et in case et' of L'.CError => (eerror, cerror, []) | L'.TCFun (_, x, k, eb) => let val () = checkKind env c' ck k val eb' = subConInCon (0, c') eb handle SynUnif => (expError env (Unif ("substitution", loc, eb)); cerror) in (*prefaces "Elab ECApp" [("e", SourcePrint.p_exp eAll), ("et", p_con env oldEt), ("x", PD.string x), ("eb", p_con (E.pushCRel env x k) eb), ("c", p_con env c'), ("eb'", p_con env eb')];*) ((L'.ECApp (e', c'), loc), eb', gs1 @ enD gs2 @ enD gs3) end | _ => (expError env (WrongForm ("constructor function", e', et)); (eerror, cerror, [])) end | L.ECAbs (expl, x, k, e) => let val expl' = elabExplicitness expl val k' = elabKind k val env' = E.pushCRel env x k' val (e', et, gs) = elabExp (env', D.enter denv) e in ((L'.ECAbs (expl', x, k', e'), loc), (L'.TCFun (expl', x, k', et), loc), gs) end | L.EDisjoint (c1, c2, e) => let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 val ku1 = kunif loc val ku2 = kunif loc val (denv', gs3) = D.assert env denv (c1', c2') val (e', t, gs4) = elabExp (env, denv') e in checkKind env c1' k1 (L'.KRecord ku1, loc); checkKind env c2' k2 (L'.KRecord ku2, loc); (e', (L'.CDisjoint (L'.LeaveAlone, c1', c2', t), loc), enD gs1 @ enD gs2 @ enD gs3 @ gs4) end | L.ERecord xes => let val (xes', gs) = ListUtil.foldlMap (fn ((x, e), gs) => let val (x', xk, gs1) = elabCon (env, denv) x val (e', et, gs2) = elabExp (env, denv) e in checkKind env x' xk kname; ((x', e', et), enD gs1 @ gs2 @ gs) end) [] xes val k = (L'.KType, loc) fun prove (xets, gs) = case xets of [] => gs | (x, _, t) :: rest => let val xc = (x, t) val r1 = (L'.CRecord (k, [xc]), loc) val gs = foldl (fn ((x', _, t'), gs) => let val xc' = (x', t') val r2 = (L'.CRecord (k, [xc']), loc) in D.prove env denv (r1, r2, loc) @ gs end) gs rest in prove (rest, gs) end val gsD = List.mapPartial (fn Disjoint d => SOME d | _ => NONE) gs val gsO = List.filter (fn Disjoint _ => false | _ => true) gs in (*TextIO.print ("|gsO| = " ^ Int.toString (length gsO) ^ "\n");*) ((L'.ERecord xes', loc), (L'.TRecord (L'.CRecord (ktype, map (fn (x', _, et) => (x', et)) xes'), loc), loc), enD (prove (xes', gsD)) @ gsO) end | L.EField (e, c) => let val (e', et, gs1) = elabExp (env, denv) e val (c', ck, gs2) = elabCon (env, denv) c val ft = cunif (loc, ktype) val rest = cunif (loc, ktype_record) val first = (L'.CRecord (ktype, [(c', ft)]), loc) val gs3 = checkCon (env, denv) e' et (L'.TRecord (L'.CConcat (first, rest), loc), loc) val gs4 = D.prove env denv (first, rest, loc) in ((L'.EField (e', c', {field = ft, rest = rest}), loc), ft, gs1 @ enD gs2 @ enD gs3 @ enD gs4) end | L.EConcat (e1, e2) => let val (e1', e1t, gs1) = elabExp (env, denv) e1 val (e2', e2t, gs2) = elabExp (env, denv) e2 val r1 = cunif (loc, ktype_record) val r2 = cunif (loc, ktype_record) val gs3 = checkCon (env, denv) e1' e1t (L'.TRecord r1, loc) val gs4 = checkCon (env, denv) e2' e2t (L'.TRecord r2, loc) val gs5 = D.prove env denv (r1, r2, loc) in ((L'.EConcat (e1', r1, e2', r2), loc), (L'.TRecord ((L'.CConcat (r1, r2), loc)), loc), gs1 @ gs2 @ enD gs3 @ enD gs4 @ enD gs5) end | L.ECut (e, c) => let val (e', et, gs1) = elabExp (env, denv) e val (c', ck, gs2) = elabCon (env, denv) c val ft = cunif (loc, ktype) val rest = cunif (loc, ktype_record) val first = (L'.CRecord (ktype, [(c', ft)]), loc) val gs3 = checkCon (env, denv) e' et (L'.TRecord (L'.CConcat (first, rest), loc), loc) val gs4 = D.prove env denv (first, rest, loc) in ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc), gs1 @ enD gs2 @ enD gs3 @ enD gs4) end | L.ECutMulti (e, c) => let val (e', et, gs1) = elabExp (env, denv) e val (c', ck, gs2) = elabCon (env, denv) c val rest = cunif (loc, ktype_record) val gs3 = checkCon (env, denv) e' et (L'.TRecord (L'.CConcat (c', rest), loc), loc) val gs4 = D.prove env denv (c', rest, loc) in ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc), gs1 @ enD gs2 @ enD gs3 @ enD gs4) end | L.EFold => let val dom = kunif loc in ((L'.EFold dom, loc), foldType (dom, loc), []) end | L.ECase (e, pes) => let val (e', et, gs1) = elabExp (env, denv) e val result = cunif (loc, (L'.KType, loc)) val (pes', gs) = ListUtil.foldlMap (fn ((p, e), gs) => let val ((p', pt), (env, _)) = elabPat (p, (env, denv, SS.empty)) val gs1 = checkPatCon (env, denv) p' pt et val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et result in ((p', e'), enD gs1 @ gs2 @ enD gs3 @ gs) end) gs1 pes val (total, gs') = exhaustive (env, denv, et, map #1 pes') in if total then () else expError env (Inexhaustive loc); ((L'.ECase (e', pes', {disc = et, result = result}), loc), result, enD gs' @ gs) end | L.ELet (eds, e) => let val (eds, (env, gs1)) = ListUtil.foldlMap (elabEdecl denv) (env, []) eds val (e, t, gs2) = elabExp (env, denv) e in ((L'.ELet (eds, e), loc), t, gs1 @ gs2) end in (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll), ("t", PD.string (LargeReal.toString (Time.toReal (Time.- (Time.now (), befor)))))];*) r end and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = let val r = case d of L.EDVal (x, co, e) => let val (c', _, gs1) = case co of NONE => (cunif (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' val c' = normClassConstraint env c' val env' = E.pushERel env x c' val c' = makeInstantiable c' in ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.EDValRec vis => let fun allowable (e, _) = case e of L.EAbs _ => true | L.ECAbs (_, _, _, e) => allowable e | L.EDisjoint (_, _, e) => allowable e | _ => false val (vis, gs) = ListUtil.foldlMap (fn ((x, co, e), gs) => let val (c', _, gs1) = case co of NONE => (cunif (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c in ((x, c', e), enD gs1 @ gs) end) gs vis val env = foldl (fn ((x, c', _), env) => E.pushERel env x c') env vis val (vis, gs) = ListUtil.foldlMap (fn ((x, c', e), gs) => let val (e', et, gs1) = elabExp (env, denv) e val gs2 = checkCon (env, denv) e' et c' val c' = makeInstantiable c' in if allowable e then () else expError env (IllegalRec (x, e')); ((x, c', e'), gs1 @ enD gs2 @ gs) end) gs vis in ((L'.EDValRec vis, loc), (env, gs)) end in r end val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun dopenConstraints (loc, env, denv) {str, strs} = case E.lookupStr env str of NONE => (strError env (UnboundStr (loc, str)); denv) | SOME (n, sgn) => let val (st, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {str = str, sgn = sgn, field = m} of NONE => (strError env (UnboundStr (loc, m)); (strerror, sgnerror)) | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) strs val cso = E.projectConstraints env {sgn = sgn, str = st} val denv = case cso of NONE => (strError env (UnboundStr (loc, str)); denv) | SOME cs => foldl (fn ((c1, c2), denv) => let val (denv, gs) = D.assert env denv (c1, c2) in case gs of [] => () | _ => raise Fail "dopenConstraints: Sub-constraints remain"; denv end) denv cs in denv end fun elabSgn_item ((sgi, loc), (env, denv, gs)) = case sgi of L.SgiConAbs (x, k) => let val k' = elabKind k val (env', n) = E.pushCNamed env x k' NONE in ([(L'.SgiConAbs (x, n, k'), loc)], (env', denv, gs)) end | L.SgiCon (x, ko, c) => let val k' = case ko of NONE => kunif loc | SOME k => elabKind k val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') in checkKind env c' ck k'; ([(L'.SgiCon (x, n, k', c'), loc)], (env', denv, gs' @ gs)) end | L.SgiDatatype (x, xs, xcs) => let val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs val (env, n) = E.pushCNamed env x k' NONE val t = (L'.CNamed n, loc) val nxs = length xs - 1 val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs val (env', denv') = foldl (fn (x, (env', denv')) => (E.pushCRel env' x k, D.enter denv')) (env, denv) xs val (xcs, (used, env, gs)) = ListUtil.foldlMap (fn ((x, to), (used, env, gs)) => let val (to, t, gs') = case to of NONE => (NONE, t, gs) | SOME t' => let val (t', tk, gs') = elabCon (env', denv') t' in checkKind env' t' tk k; (SOME t', (L'.TFun (t', t), loc), gs' @ gs) end val t = foldl (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs val (env, n') = E.pushENamed env x t in if SS.member (used, x) then strError env (DuplicateConstructor (x, loc)) else (); ((x, n', to), (SS.add (used, x), env, gs')) end) (SS.empty, env, []) xcs val env = E.pushDatatype env n xs xcs in ([(L'.SgiDatatype (x, n, xs, xcs), loc)], (env, denv, gs)) end | 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 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 (xs, xncs) => let val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs val t = (L'.CModProj (n, ms, s), loc) val (env, n') = E.pushCNamed env x k' (SOME t) val env = E.pushDatatype env n' xs 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) val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs in E.pushENamedAs env x n t end) env xncs in ([(L'.SgiDatatypeImp (x, n', n, ms, s, xs, xncs), loc)], (env, denv, gs)) end) | _ => (strError env (NotDatatype loc); ([], (env, denv, []))) end) | L.SgiVal (x, c) => let val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushENamed env x c' val c' = normClassConstraint env c' in (unifyKinds ck ktype handle KUnify ue => strError env (NotType (ck, ue))); ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) end | L.SgiStr (x, sgn) => let val (sgn', gs') = elabSgn (env, denv) sgn val (env', n) = E.pushStrNamed env x sgn' in ([(L'.SgiStr (x, n, sgn'), loc)], (env', denv, gs' @ gs)) end | L.SgiSgn (x, sgn) => let val (sgn', gs') = elabSgn (env, denv) sgn val (env', n) = E.pushSgnNamed env x sgn' in ([(L'.SgiSgn (x, n, sgn'), loc)], (env', denv, gs' @ gs)) end | L.SgiInclude sgn => let val (sgn', gs') = elabSgn (env, denv) sgn in case #1 (hnormSgn env sgn') of L'.SgnConst sgis => (sgis, (foldl (fn (sgi, env) => E.sgiBinds env sgi) env sgis, denv, gs' @ gs)) | _ => (sgnError env (NotIncludable sgn'); ([], (env, denv, []))) end | L.SgiConstraint (c1, c2) => let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 val (denv, gs3) = D.assert env denv (c1', c2') in checkKind env c1' k1 (L'.KRecord (kunif loc), loc); checkKind env c2' k2 (L'.KRecord (kunif loc), loc); ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2 @ gs3)) end | L.SgiClassAbs x => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val (env, n) = E.pushCNamed env x k NONE val env = E.pushClass env n in ([(L'.SgiClassAbs (x, n), loc)], (env, denv, [])) end | L.SgiClass (x, c) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val (c', ck, gs) = elabCon (env, denv) c val (env, n) = E.pushCNamed env x k (SOME c') val env = E.pushClass env n in checkKind env c' ck k; ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) end and elabSgn (env, denv) (sgn, loc) = case sgn of L.SgnConst sgis => let val (sgis', (_, _, gs)) = ListUtil.foldlMapConcat elabSgn_item (env, denv, []) sgis val _ = foldl (fn ((sgi, loc), (cons, vals, sgns, strs)) => case sgi of L'.SgiConAbs (x, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs)) | L'.SgiCon (x, _, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs)) | L'.SgiDatatype (x, _, _, xncs) => let val vals = foldl (fn ((x, _, _), vals) => (if SS.member (vals, x) then sgnError env (DuplicateVal (loc, x)) else (); SS.add (vals, x))) vals xncs in if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs) end | L'.SgiDatatypeImp (x, _, _, _, _, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs)) | L'.SgiVal (x, _, _) => (if SS.member (vals, x) then sgnError env (DuplicateVal (loc, x)) else (); (cons, SS.add (vals, x), sgns, strs)) | L'.SgiSgn (x, _, _) => (if SS.member (sgns, x) then sgnError env (DuplicateSgn (loc, x)) else (); (cons, vals, SS.add (sgns, x), strs)) | L'.SgiStr (x, _, _) => (if SS.member (strs, x) then sgnError env (DuplicateStr (loc, x)) else (); (cons, vals, sgns, SS.add (strs, x))) | L'.SgiConstraint _ => (cons, vals, sgns, strs) | L'.SgiClassAbs (x, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs)) | L'.SgiClass (x, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs))) (SS.empty, SS.empty, SS.empty, SS.empty) sgis' in ((L'.SgnConst sgis', loc), gs) end | L.SgnVar x => (case E.lookupSgn env x of NONE => (sgnError env (UnboundSgn (loc, x)); ((L'.SgnError, loc), [])) | SOME (n, sgis) => ((L'.SgnVar n, loc), [])) | L.SgnFun (m, dom, ran) => let val (dom', gs1) = elabSgn (env, denv) dom val (env', n) = E.pushStrNamed env m dom' val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []} val (ran', gs2) = elabSgn (env', denv') ran in ((L'.SgnFun (m, n, dom', ran'), loc), gs1 @ gs2) end | L.SgnWhere (sgn, x, c) => let val (sgn', ds1) = elabSgn (env, denv) sgn val (c', ck, ds2) = elabCon (env, denv) c in case #1 (hnormSgn env sgn') of L'.SgnError => (sgnerror, []) | L'.SgnConst sgis => if List.exists (fn (L'.SgiConAbs (x', _, k), _) => x' = x andalso (unifyKinds k ck handle KUnify x => sgnError env (WhereWrongKind x); true) | _ => false) sgis then ((L'.SgnWhere (sgn', x, c'), loc), ds1 @ ds2) else (sgnError env (UnWhereable (sgn', x)); (sgnerror, [])) | _ => (sgnError env (UnWhereable (sgn', x)); (sgnerror, [])) end | L.SgnProj (m, ms, x) => (case E.lookupStr env m of NONE => (strError env (UnboundStr (loc, m)); (sgnerror, [])) | SOME (n, sgn) => let val (str, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {sgn = sgn, str = str, field = m} of NONE => (strError env (UnboundStr (loc, m)); (strerror, sgnerror)) | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) ms in case E.projectSgn env {sgn = sgn, str = str, field = x} of NONE => (sgnError env (UnboundSgn (loc, x)); (sgnerror, [])) | SOME _ => ((L'.SgnProj (n, ms, x), loc), []) end) fun selfify env {str, strs, sgn} = case #1 (hnormSgn env sgn) of L'.SgnError => sgn | L'.SgnVar _ => sgn | 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, xs, xncs), loc) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc) | (L'.SgiClassAbs (x, n), loc) => (L'.SgiClass (x, n, (L'.CModProj (str, strs, x), loc)), 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) | L'.SgnFun _ => sgn | L'.SgnWhere _ => sgn | L'.SgnProj (m, ms, x) => case E.projectSgn env {str = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn)) (L'.StrVar m, #2 sgn) ms, sgn = #2 (E.lookupStrNamed env m), field = x} of NONE => raise Fail "Elaborate.selfify: projectSgn returns NONE" | SOME sgn => selfify env {str = str, strs = strs, sgn = sgn} fun selfifyAt env {str, sgn} = let fun self (str, _) = case str of L'.StrVar x => SOME (x, []) | L'.StrProj (str, x) => (case self str of NONE => NONE | SOME (m, ms) => SOME (m, ms @ [x])) | _ => NONE in case self str of NONE => sgn | SOME (str, strs) => selfify env {sgn = sgn, str = str, strs = strs} end fun dopen (env, denv) {str, strs, sgn} = let val m = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn)) (L'.StrVar str, #2 sgn) strs in case #1 (hnormSgn env sgn) of L'.SgnConst sgis => ListUtil.foldlMap (fn ((sgi, loc), (env', denv')) => let val d = case sgi of L'.SgiConAbs (x, n, k) => let val c = (L'.CModProj (str, strs, x), loc) in (L'.DCon (x, n, k, c), loc) end | L'.SgiCon (x, n, k, c) => (L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) | L'.SgiDatatype (x, n, xs, xncs) => (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc) | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => (L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc) | L'.SgiVal (x, n, t) => (L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc) | L'.SgiStr (x, n, sgn) => (L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc) | L'.SgiSgn (x, n, sgn) => (L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc) | L'.SgiConstraint (c1, c2) => (L'.DConstraint (c1, c2), loc) | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in (L'.DCon (x, n, k, c), loc) end | L'.SgiClass (x, n, _) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in (L'.DCon (x, n, k, c), loc) end in (d, (E.declBinds env' d, denv')) end) (env, denv) sgis | _ => (strError env (UnOpenable sgn); ([], (env, denv))) end fun sgiOfDecl (d, loc) = case d of L'.DCon (x, n, k, c) => [(L'.SgiCon (x, n, k, c), loc)] | L'.DDatatype x => [(L'.SgiDatatype x, loc)] | L'.DDatatypeImp x => [(L'.SgiDatatypeImp x, loc)] | L'.DVal (x, n, t, _) => [(L'.SgiVal (x, n, t), loc)] | L'.DValRec vis => map (fn (x, n, t, _) => (L'.SgiVal (x, n, t), loc)) vis | L'.DSgn (x, n, sgn) => [(L'.SgiSgn (x, n, sgn), loc)] | L'.DStr (x, n, sgn, _) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] fun sgiBindsD (env, denv) (sgi, _) = case sgi of L'.SgiConstraint (c1, c2) => (case D.assert env denv (c1, c2) of (denv, []) => denv | _ => raise Fail "sgiBindsD: Sub-constraints remain") | _ => denv fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2)];*) case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of (L'.SgnError, _) => () | (_, L'.SgnError) => () | (L'.SgnConst sgis1, L'.SgnConst sgis2) => let (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2), ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) fun folder (sgi2All as (sgi, loc), (env, denv)) = let (*val () = prefaces "folder" [("sgis1", p_sgn env (L'.SgnConst sgis1, loc2))]*) fun seek p = let fun seek (env, denv) ls = case ls of [] => (sgnError env (UnmatchedSgi sgi2All); (env, denv)) | h :: t => case p (env, h) of NONE => let val env = case #1 h of L'.SgiCon (x, n, k, c) => if E.checkENamed env n then env else E.pushCNamedAs env x n k (SOME c) | L'.SgiConAbs (x, n, k) => if E.checkENamed env n then env else E.pushCNamedAs env x n k NONE | _ => env in seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t end | SOME envs => envs in seek (env, denv) sgis1 end in case sgi of L'.SgiConAbs (x, n2, k2) => seek (fn (env, sgi1All as (sgi1, _)) => let fun found (x', n1, k1, co1) = if x = x' then let val () = unifyKinds k1 k2 handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) val env = E.pushCNamedAs env x n1 k1 co1 in SOME (if n1 = n2 then env else E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2)), denv) end else NONE in case sgi1 of L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE) | L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, SOME c1) | L'.SgiDatatype (x', n1, xs, _) => let val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs in found (x', n1, k', NONE) end | L'.SgiDatatypeImp (x', n1, m1, ms, s, xs, _) => let val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs in found (x', n1, k', SOME (L'.CModProj (m1, ms, s), loc)) end | L'.SgiClassAbs (x', n1) => found (x', n1, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), NONE) | L'.SgiClass (x', n1, c) => found (x', n1, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), SOME c) | _ => NONE end) | L'.SgiCon (x, n2, k2, c2) => seek (fn (env, sgi1All as (sgi1, _)) => let fun found (x', n1, k1, c1) = if x = x' then let fun good () = let val env = E.pushCNamedAs env x n2 k2 (SOME c2) val env = if n1 = n2 then env else E.pushCNamedAs env x n1 k1 (SOME c1) in SOME (env, denv) end in (case unifyCons (env, denv) c1 c2 of [] => good () | _ => NONE) handle CUnify (c1, c2, err) => (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); good ()) end else NONE in case sgi1 of L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) | L'.SgiClass (x', n1, c1) => found (x', n1, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), c1) | _ => NONE end) | L'.SgiDatatype (x, n2, xs2, xncs2) => seek (fn (env, sgi1All as (sgi1, _)) => let fun found (n1, xs1, xncs1) = let fun mismatched ue = (sgnError env (SgiMismatchedDatatypes (sgi1All, sgi2All, ue)); SOME (env, denv)) val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1 fun good () = let val env = E.sgiBinds env sgi1All val env = if n1 = n2 then env else E.pushCNamedAs env x n2 k' (SOME (L'.CNamed n1, loc)) in SOME (env, denv) end val env = E.pushCNamedAs env x n1 k' NONE val env = if n1 = n2 then env else E.pushCNamedAs env x n2 k' (SOME (L'.CNamed n1, loc)) val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 fun xncBad ((x1, _, t1), (x2, _, t2)) = String.compare (x1, x2) <> EQUAL orelse case (t1, t2) of (NONE, NONE) => false | (SOME t1, SOME t2) => not (List.null (unifyCons (env, denv) t1 t2)) | _ => true in (if xs1 <> xs2 orelse length xncs1 <> length xncs2 orelse ListPair.exists xncBad (xncs1, xncs2) then mismatched NONE else good ()) handle CUnify ue => mismatched (SOME ue) end in case sgi1 of L'.SgiDatatype (x', n1, xs, xncs1) => if x' = x then found (n1, xs, xncs1) else NONE | L'.SgiDatatypeImp (x', n1, _, _, _, xs, xncs1) => if x' = x then found (n1, xs, xncs1) else NONE | _ => NONE end) | L'.SgiDatatypeImp (x, n2, m12, ms2, s2, xs, _) => seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiDatatypeImp (x', n1, m11, ms1, s1, _, _) => if x = x' then let val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs 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 (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiVal (x', n1, c1) => if x = x' then ((*prefaces "Pre" [("c1", p_con env c1), ("c2", p_con env c2)];*) case unifyCons (env, denv) c1 c2 of [] => SOME (env, denv) | _ => NONE) handle CUnify (c1, c2, err) => (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); SOME (env, denv)) else NONE | _ => NONE) | L'.SgiStr (x, n2, sgn2) => seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiStr (x', n1, sgn1) => if x = x' then let val () = subSgn (env, denv) sgn1 sgn2 val env = E.pushStrNamedAs env x n1 sgn1 val env = if n1 = n2 then env else E.pushStrNamedAs env x n2 (selfifyAt env {str = (L'.StrVar n1, #2 sgn2), sgn = sgn2}) in SOME (env, denv) end else NONE | _ => NONE) | L'.SgiSgn (x, n2, sgn2) => seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiSgn (x', n1, sgn1) => if x = x' then let val () = subSgn (env, denv) sgn1 sgn2 val () = subSgn (env, denv) sgn2 sgn1 val env = E.pushSgnNamedAs env x n2 sgn2 val env = if n1 = n2 then env else E.pushSgnNamedAs env x n1 sgn2 in SOME (env, denv) end else NONE | _ => NONE) | L'.SgiConstraint (c2, d2) => seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiConstraint (c1, d1) => if consEq (env, denv) (c1, c2) andalso consEq (env, denv) (d1, d2) then let val (denv, gs) = D.assert env denv (c2, d2) in case gs of [] => () | _ => raise Fail "subSgn: Sub-constraints remain"; SOME (env, denv) end else NONE | _ => NONE) | L'.SgiClassAbs (x, n2) => seek (fn (env, sgi1All as (sgi1, _)) => let fun found (x', n1, co) = if x = x' then let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val env = E.pushCNamedAs env x n1 k co in SOME (if n1 = n2 then env else E.pushCNamedAs env x n2 k (SOME (L'.CNamed n1, loc2)), denv) end else NONE in case sgi1 of L'.SgiClassAbs (x', n1) => found (x', n1, NONE) | L'.SgiClass (x', n1, c) => found (x', n1, SOME c) | _ => NONE end) | L'.SgiClass (x, n2, c2) => seek (fn (env, sgi1All as (sgi1, _)) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) fun found (x', n1, c1) = if x = x' then let fun good () = let val env = E.pushCNamedAs env x n2 k (SOME c2) val env = if n1 = n2 then env else E.pushCNamedAs env x n1 k (SOME c1) in SOME (env, denv) end in (case unifyCons (env, denv) c1 c2 of [] => good () | _ => NONE) handle CUnify (c1, c2, err) => (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); good ()) end else NONE in case sgi1 of L'.SgiClass (x', n1, c1) => found (x', n1, c1) | _ => NONE end) end in ignore (foldl folder (env, denv) sgis2) end | (L'.SgnFun (m1, n1, dom1, ran1), L'.SgnFun (m2, n2, dom2, ran2)) => let val ran2 = if n1 = n2 then ran2 else subStrInSgn (n2, n1) ran2 in subSgn (env, denv) dom2 dom1; subSgn (E.pushStrNamedAs env m1 n1 dom2, denv) ran1 ran2 end | _ => sgnError env (SgnWrongForm (sgn1, sgn2))) fun positive self = let open L fun none (c, _) = case c of CAnnot (c, _) => none c | TFun (c1, c2) => none c1 andalso none c2 | TCFun (_, _, _, c) => none c | TRecord c => none c | CVar ([], x) => x <> self | CVar _ => true | CApp (c1, c2) => none c1 andalso none c2 | CAbs _ => false | CDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3 | CName _ => true | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso none c2) xcs | CConcat (c1, c2) => none c1 andalso none c2 | CFold => true | CUnit => true | CTuple cs => List.all none cs | CProj (c, _) => none c | CWild _ => false fun pos (c, _) = case c of CAnnot (c, _) => pos c | TFun (c1, c2) => none c1 andalso pos c2 | TCFun (_, _, _, c) => pos c | TRecord c => pos c | CVar _ => true | CApp (c1, c2) => pos c1 andalso none c2 | CAbs _ => false | CDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3 | CName _ => true | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso pos c2) xcs | CConcat (c1, c2) => pos c1 andalso pos c2 | CFold => true | CUnit => true | CTuple cs => List.all pos cs | CProj (c, _) => pos c | CWild _ => false in pos end fun wildifyStr env (str, sgn) = case #1 (hnormSgn env sgn) of L'.SgnConst sgis => (case #1 str of L.StrConst ds => let fun decompileKind (k, loc) = case k of L'.KType => SOME (L.KType, loc) | L'.KArrow (k1, k2) => (case (decompileKind k1, decompileKind k2) of (SOME k1, SOME k2) => SOME (L.KArrow (k1, k2), loc) | _ => NONE) | L'.KName => SOME (L.KName, loc) | L'.KRecord k => (case decompileKind k of SOME k => SOME (L.KRecord k, loc) | _ => NONE) | L'.KUnit => SOME (L.KUnit, loc) | L'.KTuple ks => let val ks' = List.mapPartial decompileKind ks in if length ks' = length ks then SOME (L.KTuple ks', loc) else NONE end | L'.KError => NONE | L'.KUnif (_, _, ref (SOME k)) => decompileKind k | L'.KUnif _ => NONE fun decompileCon env (c, loc) = case c of L'.CRel i => let val (s, _) = E.lookupCRel env i in SOME (L.CVar ([], s), loc) end | L'.CNamed i => let val (s, _, _) = E.lookupCNamed env i in SOME (L.CVar ([], s), loc) end | L'.CModProj (m1, ms, x) => let val (s, _) = E.lookupStrNamed env m1 in SOME (L.CVar (s :: ms, x), loc) end | L'.CName s => SOME (L.CName s, loc) | L'.CRecord (_, xcs) => let fun fields xcs = case xcs of [] => SOME [] | (x, t) :: xcs => case (decompileCon env x, decompileCon env t, fields xcs) of (SOME x, SOME t, SOME xcs) => SOME ((x, t) :: xcs) | _ => NONE in Option.map (fn xcs => (L.CRecord xcs, loc)) (fields xcs) end | L'.CConcat (c1, c2) => (case (decompileCon env c1, decompileCon env c2) of (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc) | _ => NONE) | L'.CUnit => SOME (L.CUnit, loc) | _ => NONE val (neededC, constraints, neededV, _) = foldl (fn ((sgi, loc), (neededC, constraints, neededV, env')) => let val (needed, constraints, neededV) = case sgi of L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, k), 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 E.isClass 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)) => 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) => let val k = case decompileKind k of NONE => (L.KWild, #2 str) | SOME k => k val cwild = (L.CWild k, #2 str) in (L.DCon (x, NONE, cwild), #2 str) end) xs in ds'' @ ds' end in (L.StrConst (ds @ ds'), #2 str) end | _ => str) | _ => str fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) (*val befor = Time.now ()*) val r = case d of L.DCon (x, ko, c) => let val k' = case ko of NONE => kunif loc | SOME k => elabKind k val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') in checkKind env c' ck k'; ([(L'.DCon (x, n, k', c'), loc)], (env', denv, enD gs' @ gs)) end | L.DDatatype (x, xs, xcs) => let val positive = List.all (fn (_, to) => case to of NONE => true | SOME t => positive x t) xcs val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs val (env, n) = E.pushCNamed env x k' NONE val t = (L'.CNamed n, loc) val nxs = length xs - 1 val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs val (env', denv') = foldl (fn (x, (env', denv')) => (E.pushCRel env' x k, D.enter denv')) (env, denv) xs val (xcs, (used, env, gs')) = ListUtil.foldlMap (fn ((x, to), (used, env, gs)) => let val (to, t, gs') = case to of NONE => (NONE, t, gs) | SOME t' => let val (t', tk, gs') = elabCon (env', denv') t' in checkKind env' t' tk k; (SOME t', (L'.TFun (t', t), loc), enD gs' @ gs) end val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs val (env, n') = E.pushENamed env x t in if SS.member (used, x) then strError env (DuplicateConstructor (x, loc)) else (); ((x, n', to), (SS.add (used, x), env, gs')) end) (SS.empty, env, []) xcs val env = E.pushDatatype env n xs xcs val d' = (L'.DDatatype (x, n, xs, xcs), loc) in if positive then () else declError env (Nonpositive d'); ([d'], (env, denv, gs' @ gs)) end | L.DDatatypeImp (_, [], _) => raise Fail "Empty DDatatypeImp" | L.DDatatypeImp (x, m1 :: ms, s) => (case E.lookupStr env m1 of NONE => (expError env (UnboundStrInExp (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 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 (xs, xncs) => let val k = (L'.KType, loc) val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs val t = (L'.CModProj (n, ms, s), loc) val (env, n') = E.pushCNamed env x k' (SOME t) val env = E.pushDatatype env n' xs 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) val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs in E.pushENamedAs env x n t end) env xncs in ([(L'.DDatatypeImp (x, n', n, ms, s, xs, xncs), loc)], (env, denv, enD gs' @ gs)) end) | _ => (strError env (NotDatatype loc); ([], (env, denv, []))) end) | L.DVal (x, co, e) => let val (c', _, gs1) = case co of NONE => (cunif (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' val c = normClassConstraint env c' val (env', n) = E.pushENamed env x c' val c' = makeInstantiable c' in (*prefaces "DVal" [("x", Print.PD.string x), ("c'", p_con env c')];*) ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.DValRec vis => let fun allowable (e, _) = case e of L.EAbs _ => true | L.ECAbs (_, _, _, e) => allowable e | L.EDisjoint (_, _, e) => allowable e | _ => false val (vis, gs) = ListUtil.foldlMap (fn ((x, co, e), gs) => let val (c', _, gs1) = case co of NONE => (cunif (loc, ktype), ktype, []) | SOME c => elabCon (env, denv) c in ((x, c', e), enD gs1 @ gs) end) gs vis val (vis, env) = ListUtil.foldlMap (fn ((x, c', e), env) => let val (env, n) = E.pushENamed env x c' in ((x, n, c', e), env) end) env vis val (vis, gs) = ListUtil.foldlMap (fn ((x, n, c', e), gs) => let val (e', et, gs1) = elabExp (env, denv) e val gs2 = checkCon (env, denv) e' et c' val c' = makeInstantiable c' in if allowable e then () else expError env (IllegalRec (x, e')); ((x, n, c', e'), gs1 @ enD gs2 @ gs) end) gs vis in ([(L'.DValRec vis, loc)], (env, denv, gs)) end | L.DSgn (x, sgn) => let val (sgn', gs') = elabSgn (env, denv) sgn val (env', n) = E.pushSgnNamed env x sgn' in ([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs)) end | L.DStr (x, sgno, str) => let val () = if x = "Basis" then raise Fail "Not allowed to redefine structure 'Basis'" else () val formal = Option.map (elabSgn (env, denv)) sgno val (str', sgn', gs') = case formal of NONE => let val (str', actual, gs') = elabStr (env, denv) str in (str', selfifyAt env {str = str', sgn = actual}, gs') end | SOME (formal, gs1) => let val str = wildifyStr env (str, formal) val (str', actual, gs2) = elabStr (env, denv) str in subSgn (env, denv) (selfifyAt env {str = str', sgn = actual}) formal; (str', formal, enD gs1 @ gs2) end val (env', n) = E.pushStrNamed env x sgn' in case #1 (hnormSgn env sgn') of L'.SgnFun _ => (case #1 str' of L'.StrFun _ => () | _ => strError env (FunctorRebind loc)) | _ => (); ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv, gs' @ gs)) end | L.DFfiStr (x, sgn) => let val (sgn', gs') = elabSgn (env, denv) sgn val (env', n) = E.pushStrNamed env x sgn' in ([(L'.DFfiStr (x, n, sgn'), loc)], (env', denv, enD gs' @ gs)) end | L.DOpen (m, ms) => (case E.lookupStr env m of NONE => (strError env (UnboundStr (loc, m)); ([], (env, denv, gs))) | SOME (n, sgn) => let val (_, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {str = str, sgn = sgn, field = m} of NONE => (strError env (UnboundStr (loc, m)); (strerror, sgnerror)) | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) ((L'.StrVar n, loc), sgn) ms val (ds, (env', denv')) = dopen (env, denv) {str = n, strs = ms, sgn = sgn} val denv' = dopenConstraints (loc, env', denv') {str = m, strs = ms} in (ds, (env', denv', gs)) end) | L.DConstraint (c1, c2) => let val (c1', k1, gs1) = elabCon (env, denv) c1 val (c2', k2, gs2) = elabCon (env, denv) c2 val gs3 = D.prove env denv (c1', c2', loc) val (denv', gs4) = D.assert env denv (c1', c2') in checkKind env c1' k1 (L'.KRecord (kunif loc), loc); checkKind env c2' k2 (L'.KRecord (kunif loc), loc); ([(L'.DConstraint (c1', c2'), loc)], (env, denv', enD gs1 @ enD gs2 @ enD gs3 @ enD gs4 @ gs)) end | L.DOpenConstraints (m, ms) => let val denv = dopenConstraints (loc, env, denv) {str = m, strs = ms} in ([], (env, denv, gs)) end | L.DExport str => let val (str', sgn, gs') = elabStr (env, denv) str val sgn = case #1 (hnormSgn env sgn) of L'.SgnConst sgis => let fun doOne (all as (sgi, _), env) = (case sgi of L'.SgiVal (x, n, t) => let fun doPage (makeRes, ran) = case hnormCon (env, denv) ran of ((L'.CApp (tf, arg), _), []) => (case (hnormCon (env, denv) tf, hnormCon (env, denv) arg) of (((L'.CModProj (basis, [], "transaction"), _), []), ((L'.CApp (tf, arg3), _), [])) => (case (basis = !basis_r, hnormCon (env, denv) tf, hnormCon (env, denv) arg3) of (true, ((L'.CApp (tf, arg2), _), []), (((L'.CRecord (_, []), _), []))) => (case (hnormCon (env, denv) tf) of ((L'.CApp (tf, arg1), _), []) => (case (hnormCon (env, denv) tf, hnormCon (env, denv) arg1, hnormCon (env, denv) arg2) of ((tf, []), (arg1, []), ((L'.CRecord (_, []), _), [])) => let val t = (L'.CApp (tf, arg1), loc) val t = (L'.CApp (t, arg2), loc) val t = (L'.CApp (t, arg3), loc) val t = (L'.CApp ( (L'.CModProj (basis, [], "transaction"), loc), t), loc) in (L'.SgiVal (x, n, makeRes t), loc) end | _ => all) | _ => all) | _ => all) | _ => all) | _ => all in case hnormCon (env, denv) t of ((L'.TFun (dom, ran), _), []) => (case hnormCon (env, denv) dom of ((L'.TRecord domR, _), []) => doPage (fn t => (L'.TFun ((L'.TRecord domR, loc), t), loc), ran) | _ => all) | _ => doPage (fn t => t, t) end | _ => all, E.sgiBinds env all) in (L'.SgnConst (#1 (ListUtil.foldlMap doOne env sgis)), loc) end | _ => sgn in ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs)) end | L.DTable (x, c) => let val (c', k, gs') = elabCon (env, denv) c val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc) in checkKind env c' k (L'.KRecord (L'.KType, loc), loc); ([(L'.DTable (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end | L.DSequence x => let val (env, n) = E.pushENamed env x (sequenceOf ()) in ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) end | L.DClass (x, c) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val (c', ck, gs') = elabCon (env, denv) c val (env, n) = E.pushCNamed env x k (SOME c') val env = E.pushClass env n in checkKind env c' ck k; ([(L'.DClass (x, n, c'), loc)], (env, denv, enD gs' @ gs)) end | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) | L.DCookie (x, c) => let val (c', k, gs') = elabCon (env, denv) c val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) in checkKind env c' k (L'.KType, loc); ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), ("t", PD.string (LargeReal.toString (Time.toReal (Time.- (Time.now (), befor)))))];*) r end and elabStr (env, denv) (str, loc) = case str of L.StrConst ds => let val (ds', (_, _, gs)) = ListUtil.foldlMapConcat elabDecl (env, denv, []) ds val sgis = ListUtil.mapConcat sgiOfDecl ds' val (sgis, _, _, _, _) = foldr (fn ((sgi, loc), (sgis, cons, vals, sgns, strs)) => case sgi of L'.SgiConAbs (x, n, k) => let val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in ((L'.SgiConAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiCon (x, n, k, c) => let val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in ((L'.SgiCon (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiDatatype (x, n, xs, xncs) => let val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) val (xncs, vals) = ListUtil.foldlMap (fn ((x, n, t), vals) => if SS.member (vals, x) then (("?" ^ x, n, t), vals) else ((x, n, t), SS.add (vals, x))) vals xncs in ((L'.SgiDatatype (x, n, xs, xncs), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => let val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in ((L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiVal (x, n, c) => let val (vals, x) = if SS.member (vals, x) then (vals, "?" ^ x) else (SS.add (vals, x), x) in ((L'.SgiVal (x, n, c), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiSgn (x, n, sgn) => let val (sgns, x) = if SS.member (sgns, x) then (sgns, "?" ^ x) else (SS.add (sgns, x), x) in ((L'.SgiSgn (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiStr (x, n, sgn) => let val (strs, x) = if SS.member (strs, x) then (strs, "?" ^ x) else (SS.add (strs, x), x) in ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in ((L'.SgiClassAbs (x, n), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiClass (x, n, c) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis in ((L'.StrConst ds', loc), (L'.SgnConst sgis, loc), gs) end | L.StrVar x => (case E.lookupStr env x of NONE => (strError env (UnboundStr (loc, x)); (strerror, sgnerror, [])) | SOME (n, sgn) => ((L'.StrVar n, loc), sgn, [])) | L.StrProj (str, x) => let val (str', sgn, gs) = elabStr (env, denv) str in case E.projectStr env {str = str', sgn = sgn, field = x} of NONE => (strError env (UnboundStr (loc, x)); (strerror, sgnerror, [])) | SOME sgn => ((L'.StrProj (str', x), loc), sgn, gs) end | L.StrFun (m, dom, ranO, str) => let val (dom', gs1) = elabSgn (env, denv) dom val (env', n) = E.pushStrNamed env m dom' val (str', actual, gs2) = elabStr (env', denv) str val (formal, gs3) = case ranO of NONE => (actual, []) | SOME ran => let val (ran', gs) = elabSgn (env', denv) ran in subSgn (env', denv) actual ran'; (ran', gs) end in ((L'.StrFun (m, n, dom', formal, str'), loc), (L'.SgnFun (m, n, dom', formal), loc), enD gs1 @ gs2 @ enD gs3) end | L.StrApp (str1, str2) => let val (str1', sgn1, gs1) = elabStr (env, denv) str1 val str2 = case sgn1 of (L'.SgnFun (_, _, dom, _), _) => wildifyStr env (str2, dom) | _ => str2 val (str2', sgn2, gs2) = elabStr (env, denv) str2 in case #1 (hnormSgn env sgn1) of L'.SgnError => (strerror, sgnerror, []) | L'.SgnFun (m, n, dom, ran) => (subSgn (env, denv) sgn2 dom; case #1 (hnormSgn env ran) of L'.SgnError => (strerror, sgnerror, []) | L'.SgnConst sgis => ((L'.StrApp (str1', str2'), loc), (L'.SgnConst ((L'.SgiStr (m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), gs1 @ gs2) | _ => raise Fail "Unable to hnormSgn in functor application") | _ => (strError env (NotFunctor sgn1); (strerror, sgnerror, [])) end fun elabFile basis topStr topSgn env file = let val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan) val () = case gs of [] => () | _ => (app (fn (_, env, _, c1, c2) => prefaces "Unresolved" [("c1", p_con env c1), ("c2", p_con env c2)]) gs; raise Fail "Unresolved disjointness constraints in Basis") val (env', basis_n) = E.pushStrNamed env "Basis" sgn val () = basis_r := basis_n val (ds, (env', _)) = dopen (env', D.empty) {str = basis_n, strs = [], sgn = sgn} fun discoverC r x = case E.lookupC env' x of E.NotBound => raise Fail ("Constructor " ^ x ^ " unbound in Basis") | E.Rel _ => raise Fail ("Constructor " ^ x ^ " bound relatively in Basis") | E.Named (n, (_, loc)) => r := (L'.CNamed n, loc) val () = discoverC int "int" val () = discoverC float "float" val () = discoverC string "string" val () = discoverC table "sql_table" val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan) val () = case gs of [] => () | _ => raise Fail "Unresolved disjointness constraints in top.urs" val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan) val () = case gs of [] => () | _ => app (fn Disjoint (loc, env, denv, c1, c2) => (case D.prove env denv (c1, c2, loc) of [] => () | _ => (prefaces "Unresolved constraint in top.ur" [("loc", PD.string (ErrorMsg.spanToString loc)), ("c1", p_con env c1), ("c2", p_con env c2)]; raise Fail "Unresolved constraint in top.ur")) | TypeClass _ => raise Fail "Unresolved type class constraint in top.ur") gs val () = subSgn (env', D.empty) topSgn' topSgn val (env', top_n) = E.pushStrNamed env' "Top" topSgn val (ds', (env', _)) = dopen (env', D.empty) {str = top_n, strs = [], sgn = topSgn} fun elabDecl' (d, (env, gs)) = let val () = resetKunif () val () = resetCunif () val (ds, (env, _, gs)) = elabDecl (d, (env, D.empty, gs)) in if ErrorMsg.anyErrors () then () else ( if List.exists kunifsInDecl ds then declError env (KunifsRemain ds) else (); case ListUtil.search cunifsInDecl ds of NONE => () | SOME loc => declError env (CunifsRemain ds) ); (ds, (env, gs)) end val (file, (_, gs)) = ListUtil.foldlMapConcat elabDecl' (env', []) file in if ErrorMsg.anyErrors () then () else app (fn Disjoint (loc, env, denv, c1, c2) => (case D.prove env denv (c1, c2, loc) of [] => () | _ => (ErrorMsg.errorAt loc "Couldn't prove field name disjointness"; eprefaces' [("Con 1", p_con env c1), ("Con 2", p_con env c2), ("Hnormed 1", p_con env (ElabOps.hnormCon env c1)), ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) | TypeClass (env, c, r, loc) => let val c = normClassKey env c in case E.resolveClass env c of SOME e => r := SOME e | NONE => expError env (Unresolvable (loc, c)) end) gs; (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan) :: ds' @ file end end