Mercurial > urweb
changeset 31:1c91c5e6840f
Simple signature matching
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 12 Jun 2008 17:16:20 -0400 |
| parents | e6ccf961d8a3 |
| children | 0ff8c2728634 |
| files | src/cjr_print.sml src/compiler.sig src/compiler.sml src/core_print.sml src/corify.sml src/elab.sml src/elab_env.sig src/elab_env.sml src/elab_print.sig src/elab_print.sml src/elaborate.sig src/elaborate.sml src/flat_print.sml src/lacweb.lex src/list_util.sig src/list_util.sml src/mono_print.sml tests/modules.lac |
| diffstat | 18 files changed, 565 insertions(+), 98 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/cjr_print.sml Thu Jun 12 17:16:20 2008 -0400 @@ -186,9 +186,9 @@ fun p_file env file = let - val (_, pds) = ListUtil.mapfoldl (fn (d, env) => - (E.declBinds env d, - p_decl env d)) + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) env file in p_list_sep newline (fn x => x) pds
--- a/src/compiler.sig Thu Jun 12 14:04:22 2008 -0400 +++ b/src/compiler.sig Thu Jun 12 17:16:20 2008 -0400 @@ -32,7 +32,7 @@ val compile : string -> unit val parse : string -> Source.file option - val elaborate : ElabEnv.env -> string -> (ElabEnv.env * Elab.file) option + val elaborate : ElabEnv.env -> string -> (Elab.file * ElabEnv.env) option val corify : ElabEnv.env -> CoreEnv.env -> string -> Core.file option val reduce : ElabEnv.env -> CoreEnv.env -> string -> Core.file option val shake : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
--- a/src/compiler.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/compiler.sml Thu Jun 12 17:16:20 2008 -0400 @@ -70,7 +70,7 @@ fun corify eenv cenv filename = case elaborate eenv filename of NONE => NONE - | SOME (_, file) => + | SOME (file, _) => if ErrorMsg.anyErrors () then NONE else @@ -131,7 +131,7 @@ fun testElaborate filename = (case elaborate ElabEnv.basis filename of NONE => print "Failed\n" - | SOME (_, file) => + | SOME (file, _) => (Print.print (ElabPrint.p_file ElabEnv.basis file); print "\n")) handle ElabEnv.UnboundNamed n =>
--- a/src/core_print.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/core_print.sml Thu Jun 12 17:16:20 2008 -0400 @@ -258,9 +258,9 @@ fun p_file env file = let - val (_, pds) = ListUtil.mapfoldl (fn (d, env) => - (E.declBinds env d, - p_decl env d)) + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) env file in p_list_sep newline (fn x => x) pds
--- a/src/corify.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/corify.sml Thu Jun 12 17:16:20 2008 -0400 @@ -83,6 +83,9 @@ L.DCon (x, n, k, c) => (L'.DCon (x, n, corifyKind k, corifyCon c), loc) | L.DVal (x, n, t, e) => (L'.DVal (x, n, corifyCon t, corifyExp e), loc) + | L.DSgn _ => raise Fail "Not ready to corify signature" + | L.DStr _ => raise Fail "Not ready to corify structure" + val corify = map corifyDecl end
--- a/src/elab.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elab.sml Thu Jun 12 17:16:20 2008 -0400 @@ -80,12 +80,34 @@ withtype exp = exp' located +datatype sgn_item' = + SgiConAbs of string * int * kind + | SgiCon of string * int * kind * con + | SgiVal of string * int * con + | SgiStr of string * int * sgn + +and sgn' = + SgnConst of sgn_item list + | SgnVar of int + | SgnError + +withtype sgn_item = sgn_item' located +and sgn = sgn' located + datatype decl' = DCon of string * int * kind * con | DVal of string * int * con * exp + | DSgn of string * int * sgn + | DStr of string * int * sgn * str + + and str' = + StrConst of decl list + | StrVar of int + | StrError withtype decl = decl' located - + and str = str' located + type file = decl list end
--- a/src/elab_env.sig Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elab_env.sig Thu Jun 12 17:16:20 2008 -0400 @@ -58,9 +58,22 @@ val pushENamed : env -> string -> Elab.con -> env * int val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con - + val lookupE : env -> string -> Elab.con var + val pushSgnNamed : env -> string -> Elab.sgn -> env * int + val pushSgnNamedAs : env -> string -> int -> Elab.sgn -> env + val lookupSgnNamed : env -> int -> string * Elab.sgn + + val lookupSgn : env -> string -> (int * Elab.sgn) option + + val pushStrNamed : env -> string -> Elab.sgn -> env * int + val pushStrNamedAs : env -> string -> int -> Elab.sgn -> env + val lookupStrNamed : env -> int -> string * Elab.sgn + + val lookupStr : env -> string -> (int * Elab.sgn) option + val declBinds : env -> Elab.decl -> env + val sgiBinds : env -> Elab.sgn_item -> env end
--- a/src/elab_env.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elab_env.sml Thu Jun 12 17:16:20 2008 -0400 @@ -80,7 +80,13 @@ renameE : con var' SM.map, relE : (string * con) list, - namedE : (string * con) IM.map + namedE : (string * con) IM.map, + + renameSgn : (int * sgn) SM.map, + sgn : (string * sgn) IM.map, + + renameStr : (int * sgn) SM.map, + str : (string * sgn) IM.map } val namedCounter = ref 0 @@ -92,7 +98,13 @@ renameE = SM.empty, relE = [], - namedE = IM.empty + namedE = IM.empty, + + renameSgn = SM.empty, + sgn = IM.empty, + + renameStr = SM.empty, + str = IM.empty } fun pushCRel (env : env) x k = @@ -106,7 +118,14 @@ renameE = #renameE env, relE = map (fn (x, c) => (x, lift c)) (#relE env), - namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env)} + namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env), + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env + } end fun lookupCRel (env : env) n = @@ -120,7 +139,13 @@ renameE = #renameE env, relE = #relE env, - namedE = #namedE env} + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} fun pushCNamed env x k co = let @@ -152,7 +177,13 @@ renameE = SM.insert (renameE, x, Rel' (0, t)), relE = (x, t) :: #relE env, - namedE = #namedE env} + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} end fun lookupERel (env : env) n = @@ -166,7 +197,13 @@ renameE = SM.insert (#renameE env, x, Named' (n, t)), relE = #relE env, - namedE = IM.insert (#namedE env, n, (x, t))} + namedE = IM.insert (#namedE env, n, (x, t)), + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} fun pushENamed env x t = let @@ -187,10 +224,80 @@ | SOME (Rel' x) => Rel x | SOME (Named' x) => Named x +fun pushSgnNamedAs (env : env) x n sgis = + {renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = SM.insert (#renameSgn env, x, (n, sgis)), + sgn = IM.insert (#sgn env, n, (x, sgis)), + + renameStr = #renameStr env, + str = #str env} + +fun pushSgnNamed env x sgis = + let + val n = !namedCounter + in + namedCounter := n + 1; + (pushSgnNamedAs env x n sgis, n) + end + +fun lookupSgnNamed (env : env) n = + case IM.find (#sgn env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupSgn (env : env) x = SM.find (#renameSgn env, x) + +fun pushStrNamedAs (env : env) x n sgis = + {renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = SM.insert (#renameStr env, x, (n, sgis)), + str = IM.insert (#str env, n, (x, sgis))} + +fun pushStrNamed env x sgis = + let + val n = !namedCounter + in + namedCounter := n + 1; + (pushStrNamedAs env x n sgis, n) + end + +fun lookupStrNamed (env : env) n = + case IM.find (#str env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupStr (env : env) x = SM.find (#renameStr env, x) + fun declBinds env (d, _) = case d of DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) | DVal (x, n, t, _) => pushENamedAs env x n t + | DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn + | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn + +fun sgiBinds env (sgi, _) = + case sgi of + SgiConAbs (x, n, k) => pushCNamedAs env x n k NONE + | SgiCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) + | SgiVal (x, n, t) => pushENamedAs env x n t + | SgiStr (x, n, sgn) => pushStrNamedAs env x n sgn + val ktype = (KType, ErrorMsg.dummySpan)
--- a/src/elab_print.sig Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elab_print.sig Thu Jun 12 17:16:20 2008 -0400 @@ -33,6 +33,7 @@ val p_con : ElabEnv.env -> Elab.con Print.printer val p_exp : ElabEnv.env -> Elab.exp Print.printer val p_decl : ElabEnv.env -> Elab.decl Print.printer + val p_sgn_item : ElabEnv.env -> Elab.sgn_item Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer val debug : bool ref
--- a/src/elab_print.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elab_print.sml Thu Jun 12 17:16:20 2008 -0400 @@ -228,57 +228,119 @@ and p_exp env = p_exp' false env +fun p_named x n = + if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + +fun p_sgn_item env (sgi, _) = + case sgi of + SgiConAbs (x, n, k) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind k] + | SgiCon (x, n, k, c) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con env c] + | SgiVal (x, n, c) => box [string "val", + space, + p_named x n, + space, + string ":", + space, + p_con env c] + | SgiStr (x, n, sgn) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] + +and p_sgn env (sgn, _) = + case sgn of + SgnConst sgis => box [string "sig", + newline, + p_list_sep newline (p_sgn_item env) sgis, + newline, + string "end"] + | SgnVar n => string (#1 (E.lookupSgnNamed env n)) + | SgnError => string "<ERROR>" + fun p_decl env ((d, _) : decl) = case d of - DCon (x, n, k, c) => - let - val xp = if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x - in - box [string "con", - space, - xp, - space, - string "::", - space, - p_kind k, - space, - string "=", - space, - p_con env c] - end - | DVal (x, n, t, e) => - let - val xp = if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x - in - box [string "val", - space, - xp, - space, - string ":", - space, - p_con env t, - space, - string "=", - space, - p_exp env e] - end + DCon (x, n, k, c) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con env c] + | DVal (x, n, t, e) => box [string "val", + space, + p_named x n, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] + + | DSgn (x, n, sgn) => box [string "signature", + space, + p_named x n, + space, + string "=", + space, + p_sgn env sgn] + | DStr (x, n, sgn, str) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn, + space, + string "=", + space, + p_str env str] + +and p_str env (str, _) = + case str of + StrConst ds => box [string "struct", + newline, + p_list_sep newline (p_decl env) ds, + newline, + string "end"] + | StrVar n => string (#1 (E.lookupStrNamed env n)) + | StrError => string "<ERROR>" fun p_file env file = let - val (_, pds) = ListUtil.mapfoldl (fn (d, env) => - (E.declBinds env d, - p_decl env d)) - env file + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) + env file in p_list_sep newline (fn x => x) pds end
--- a/src/elaborate.sig Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elaborate.sig Thu Jun 12 17:16:20 2008 -0400 @@ -27,6 +27,6 @@ signature ELABORATE = sig - val elabFile : ElabEnv.env -> Source.file -> ElabEnv.env * Elab.file + val elabFile : ElabEnv.env -> Source.file -> Elab.file * ElabEnv.env end
--- a/src/elaborate.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/elaborate.sml Thu Jun 12 17:16:20 2008 -0400 @@ -135,6 +135,8 @@ 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) local val count = ref 0 @@ -864,7 +866,220 @@ (ErrorMsg.errorAt loc "Some constructor unification variables are undetermined in expression"; eprefaces' [("Expression", p_exp env e)]) -fun elabDecl env (d, loc) = +datatype sgn_error = + UnboundSgn of ErrorMsg.span * string + | UnmatchedSgi of L'.sgn_item + | SgiWrongKind of L'.sgn_item * L'.kind * L'.sgn_item * L'.kind * kunify_error + | SgiWrongCon of L'.sgn_item * L'.con * L'.sgn_item * L'.con * cunify_error + +fun sgnError env err = + case err of + UnboundSgn (loc, s) => + ErrorMsg.errorAt loc ("Unbound signature variable " ^ s) + | UnmatchedSgi (sgi as (_, loc)) => + (ErrorMsg.errorAt loc "Unmatched signature item"; + eprefaces' [("Item", p_sgn_item env sgi)]) + | SgiWrongKind (sgi1, k1, sgi2, k2, kerr) => + (ErrorMsg.errorAt (#2 sgi1) "Kind unification failure in signature matching:"; + eprefaces' [("Item 1", p_sgn_item env sgi1), + ("Item 2", p_sgn_item env sgi2), + ("Kind 1", p_kind k1), + ("Kind 2", p_kind k2)]; + kunifyError kerr) + | SgiWrongCon (sgi1, c1, sgi2, c2, cerr) => + (ErrorMsg.errorAt (#2 sgi1) "Constructor unification failure in signature matching:"; + eprefaces' [("Item 1", p_sgn_item env sgi1), + ("Item 2", p_sgn_item env sgi2), + ("Con 1", p_con env c1), + ("Con 2", p_con env c2)]; + cunifyError env cerr) + +datatype str_error = + UnboundStr of ErrorMsg.span * string + +fun strError env err = + case err of + UnboundStr (loc, s) => + ErrorMsg.errorAt loc ("Unbound structure variable " ^ s) + + +fun elabSgn_item ((sgi, loc), env) = + let + + in + resetKunif (); + resetCunif (); + case sgi of + L.SgiConAbs (x, k) => + let + val k' = elabKind k + + val (env', n) = E.pushCNamed env x k' NONE + in + if ErrorMsg.anyErrors () then + () + else ( + if kunifsInKind k' then + declError env (KunifsRemainKind (loc, k')) + else + () + ); + + ((L'.SgiConAbs (x, n, k'), loc), env') + end + + | L.SgiCon (x, ko, c) => + let + val k' = case ko of + NONE => kunif () + | SOME k => elabKind k + + val (c', ck) = elabCon env c + val (env', n) = E.pushCNamed env x k' (SOME c') + in + checkKind env c' ck k'; + + if ErrorMsg.anyErrors () then + () + else ( + if kunifsInKind k' then + declError env (KunifsRemainKind (loc, k')) + else + (); + + if kunifsInCon c' then + declError env (KunifsRemainCon (loc, c')) + else + () + ); + + ((L'.SgiCon (x, n, k', c'), loc), env') + end + + | L.SgiVal (x, c) => + let + val (c', ck) = elabCon env c + + val (env', n) = E.pushENamed env x c' + in + unifyKinds ck ktype; + + if ErrorMsg.anyErrors () then + () + else ( + if kunifsInCon c' then + declError env (KunifsRemainCon (loc, c')) + else + () + ); + + ((L'.SgiVal (x, n, c'), loc), env') + end + + | L.SgiStr (x, sgn) => + let + val sgn' = elabSgn env sgn + val (env', n) = E.pushStrNamed env x sgn' + in + ((L'.SgiStr (x, n, sgn'), loc), env') + end + + end + +and elabSgn env (sgn, loc) = + case sgn of + L.SgnConst sgis => + let + val (sgis', _) = ListUtil.foldlMap elabSgn_item env sgis + in + (L'.SgnConst sgis', loc) + 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)) + +fun sgiOfDecl (d, loc) = + case d of + L'.DCon (x, n, k, c) => SOME (L'.SgiCon (x, n, k, c), loc) + | L'.DVal (x, n, t, _) => SOME (L'.SgiVal (x, n, t), loc) + | L'.DSgn _ => NONE + | L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc) + +fun subSgn env (all1 as (sgn1, _)) (all2 as (sgn2, loc2)) = + case (sgn1, sgn2) of + (L'.SgnError, _) => () + | (_, L'.SgnError) => () + + | (L'.SgnVar n, _) => + subSgn env (#2 (E.lookupSgnNamed env n)) all2 + | (_, L'.SgnVar n) => + subSgn env all1 (#2 (E.lookupSgnNamed env n)) + + | (L'.SgnConst sgis1, L'.SgnConst sgis2) => + let + fun folder (sgi2All as (sgi, _), env) = + let + fun seek p = + let + fun seek env ls = + case ls of + [] => (sgnError env (UnmatchedSgi sgi2All); + env) + | h :: t => + case p h of + NONE => seek (E.sgiBinds env h) t + | SOME env => env + in + seek env sgis1 + end + in + case sgi of + L'.SgiConAbs (x, n2, k2) => + seek (fn sgi1All as (sgi1, _) => + let + fun found (x, n1, k1, co1) = + 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))) + end + 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) + | _ => NONE + end) + + | L'.SgiCon (x, n2, k2, c2) => + seek (fn sgi1All as (sgi1, _) => + case sgi1 of + L'.SgiCon (x, n1, k1, c1) => + let + val () = unifyCons env c1 c2 + handle CUnify (c1, c2, err) => + sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)) + in + SOME (E.pushCNamedAs env x n2 k2 (SOME c2)) + end + | _ => NONE) + + | _ => raise Fail "Not ready for more sig matching" + end + in + ignore (foldl folder env sgis2) + end + + +fun elabDecl ((d, loc), env) = let in @@ -896,8 +1111,7 @@ () ); - (env', - (L'.DCon (x, n, k', c'), loc)) + ((L'.DCon (x, n, k', c'), loc), env') end | L.DVal (x, co, e) => let @@ -933,15 +1147,50 @@ else ()); - (env', - (L'.DVal (x, n, c', e'), loc)) + ((L'.DVal (x, n, c', e'), loc), env') end - | L.DSgn _ => raise Fail "Not ready to elaborate signature" - | L.DStr _ => raise Fail "Not ready to elaborate structure" + | L.DSgn (x, sgn) => + let + val sgn' = elabSgn env sgn + val (env', n) = E.pushSgnNamed env x sgn' + in + ((L'.DSgn (x, n, sgn'), loc), env') + end + + | L.DStr (x, sgno, str) => + let + val formal = Option.map (elabSgn env) sgno + val (str', actual) = elabStr env str + + val sgn' = case formal of + NONE => actual + | SOME formal => + (subSgn env actual formal; + formal) + + val (env', n) = E.pushStrNamed env x sgn' + in + ((L'.DStr (x, n, sgn', str'), loc), env') + end end -fun elabFile env ds = - ListUtil.mapfoldl (fn (d, env) => elabDecl env d) env ds +and elabStr env (str, loc) = + case str of + L.StrConst ds => + let + val (ds', env') = ListUtil.foldlMap elabDecl env ds + val sgis = List.mapPartial sgiOfDecl ds' + in + ((L'.StrConst ds', loc), (L'.SgnConst sgis, loc)) + 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)) + +val elabFile = ListUtil.foldlMap elabDecl end
--- a/src/flat_print.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/flat_print.sml Thu Jun 12 17:16:20 2008 -0400 @@ -187,9 +187,9 @@ fun p_file env file = let - val (_, pds) = ListUtil.mapfoldl (fn (d, env) => - (E.declBinds env d, - p_decl env d)) + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) env file in p_list_sep newline (fn x => x) pds
--- a/src/lacweb.lex Thu Jun 12 14:04:22 2008 -0400 +++ b/src/lacweb.lex Thu Jun 12 17:16:20 2008 -0400 @@ -129,7 +129,7 @@ <INITIAL> "fn" => (Tokens.FN (yypos, yypos + size yytext)); <INITIAL> "structure" => (Tokens.STRUCTURE (yypos, yypos + size yytext)); -<INITIAL> "signature" => (Tokens.STRUCTURE (yypos, yypos + size yytext)); +<INITIAL> "signature" => (Tokens.SIGNATURE (yypos, yypos + size yytext)); <INITIAL> "struct" => (Tokens.STRUCT (yypos, yypos + size yytext)); <INITIAL> "sig" => (Tokens.SIG (yypos, yypos + size yytext)); <INITIAL> "end" => (Tokens.END (yypos, yypos + size yytext));
--- a/src/list_util.sig Thu Jun 12 14:04:22 2008 -0400 +++ b/src/list_util.sig Thu Jun 12 17:16:20 2008 -0400 @@ -27,9 +27,6 @@ signature LIST_UTIL = sig - val mapfoldl : ('data1 * 'state -> 'state * 'data2) -> 'state -> 'data1 list - -> 'state * 'data2 list - val mapfold : ('data, 'state, 'abort) Search.mapfolder -> ('data list, 'state, 'abort) Search.mapfolder
--- a/src/list_util.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/list_util.sml Thu Jun 12 17:16:20 2008 -0400 @@ -27,21 +27,6 @@ structure ListUtil :> LIST_UTIL = struct -fun mapfoldl f i = - let - fun mf s ls' ls = - case ls of - nil => (s, rev ls') - | h :: t => - let - val (s, h') = f (h, s) - in - mf s (h' :: ls') t - end - in - mf i [] - end - structure S = Search fun mapfold f =
--- a/src/mono_print.sml Thu Jun 12 14:04:22 2008 -0400 +++ b/src/mono_print.sml Thu Jun 12 17:16:20 2008 -0400 @@ -130,9 +130,9 @@ fun p_file env file = let - val (_, pds) = ListUtil.mapfoldl (fn (d, env) => - (E.declBinds env d, - p_decl env d)) + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) env file in p_list_sep newline (fn x => x) pds
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/modules.lac Thu Jun 12 17:16:20 2008 -0400 @@ -0,0 +1,28 @@ +signature A = sig end +structure A = struct end +structure Ao : A = A + + +structure B = struct + type t = int +end +structure Bo0 : sig end = B +structure BoA : A = B + +signature B1 = sig + type t +end +structure Bo1 : B1 = B +(*structure AoB1 : B1 = A*) + +signature B2 = sig + type t = int +end +structure Bo2 : B2 = B + + +structure C = struct + type t = float +end +structure CoB1 : B1 = C +(*structure CoB2 : B2 = C*)