val errorTy = Types.WILDCARDty
- val ppstream = PrettyPrint.mk_ppstream {consumer = TextIO.print, flush = fn () => TextIO.flushOut TextIO.stdOut,
- linewidth = 80}
+ (*val ppstream = PrettyPrint.mk_ppstream {consumer = TextIO.print, flush = fn () => TextIO.flushOut TextIO.stdOut,
+ linewidth = 80}*)
+
+ datatype unify =
+ ExpUn of exp
+ | PatUn of pat
(* States to thread throughout translation *)
local
(case StaticEnv.look (env, Symbol.varSymbol v) of
Bindings.CONbind (Types.DATACON {typ, ...}) => #1 (TypesUtil.instantiatePoly typ)
| _ => raise Fail "Unexpected binding in lookVal")
+
+
fun lookCon (env, v, pos) = (lookCon' (env, v))
handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v);
errorTy)
fun getVal (STRCT {elements, ...}, v, pos) =
(case ModuleUtil.getSpec (elements, Symbol.varSymbol v) of
Modules.VALspec {spec, ...} => #1 (TypesUtil.instantiatePoly spec)
- | _ => raise Fail "Unexpected spec in getVal")
+ | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ)
+ | _ => raise Fail ("Unexpected spec in getVal for " ^ v))
handle ModuleUtil.Unbound _ => (case ModuleUtil.getSpec (elements, Symbol.tycSymbol v) of
Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ)
| _ => raise Fail "Unexpected spec in getVal")
handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v);
errorTy)
- fun unify (STATE {env, ...}) (pos, t1, t2) =
+ fun unify (STATE {env, ...}) (pos, e, t1, t2) =
(*let
val t1 = ModuleUtil.transType eenv t1
val t2 = ModuleUtil.transType eenv t2
Unify.unifyTy (t1, t2)
(*end*)
handle Unify.Unify msg =>
- (PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 0;
- PrettyPrint.add_string ppstream "Error unifying\n\t";
- PrettyPrint.add_break ppstream (0, 0);
- PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
+ ((*PrettyPrint.openBox ppstream (PrettyPrint.Abs 0);
+ PrettyPrint.string ppstream "Error unifying";
+ PrettyPrint.newline ppstream;
+ PrettyPrint.openBox ppstream (PrettyPrint.Abs 5);
PPType.ppType env ppstream t1;
- PrettyPrint.end_block ppstream;
- PrettyPrint.add_break ppstream (0, 0);
- PrettyPrint.add_string ppstream "\nand\n\t";
- PrettyPrint.add_break ppstream (0, 0);
- PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
+ PrettyPrint.closeBox ppstream;
+ PrettyPrint.newline ppstream;
+ PrettyPrint.string ppstream "and";
+ PrettyPrint.newline ppstream;
+ PrettyPrint.openBox ppstream (PrettyPrint.Abs 5);
PPType.ppType env ppstream t2;
- PrettyPrint.end_block ppstream;
- PrettyPrint.add_string ppstream "\n";
- PrettyPrint.end_block ppstream;
- PrettyPrint.flush_ppstream ppstream;
- error (SOME pos, Unify.failMessage msg))
+ PrettyPrint.closeBox ppstream;
+ PrettyPrint.closeBox ppstream;
+ PrettyPrint.newline ppstream;
+ PrettyPrint.flushStream ppstream;*)
+ error (SOME pos, Unify.failMessage msg ^ " for " ^ (case e of ExpUn e => Tree.expString e
+ | PatUn p => "<pat>")))
fun resolvePath (getter, transer) (pos, state, path) =
let
val templateTy = BasicTypes.--> (Types.CONty (BasicTypes.listTycon,
[mkTuple [BasicTypes.stringTy,
- BasicTypes.stringTy]]), BasicTypes.unitTy)
+ Types.CONty (BasicTypes.listTycon,
+ [BasicTypes.stringTy])]]), BasicTypes.unitTy)
- fun xexp state (EXP (e, pos)) =
+ fun xexp state (exp as EXP (e, pos)) =
(case e of
Int_e n =>
(BasicTypes.intTy, Int.toString n)
+ | Real_e n =>
+ (BasicTypes.realTy, Real.toString n)
| String_e s =>
(BasicTypes.stringTy, "\"" ^ s ^ "\"")
| Char_e s =>
val xt = mkTuple [ty1, ty2]
in
- unify state (pos, dom, xt);
+ unify state (pos, ExpUn exp, dom, xt);
(ran, "(" ^ es1 ^ ") :: (" ^ es2 ^ ")")
end
+ | Compose_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+
+ val dom1 = newTyvar false
+ val ran1dom2 = newTyvar false
+ val ran2 = newTyvar false
+ in
+ unify state (pos, ExpUn exp, ty2, BasicTypes.--> (dom1, ran1dom2));
+ unify state (pos, ExpUn exp, ty1, BasicTypes.--> (ran1dom2, ran2));
+ (BasicTypes.--> (dom1, ran2), "(" ^ es1 ^ ") o (" ^ es2 ^ ")")
+ end
| StrCat_e (e1, e2) =>
let
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.stringTy);
- unify state (pos, ty2, BasicTypes.stringTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.stringTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.stringTy);
(BasicTypes.stringTy, "(" ^ es1 ^ ") ^ (" ^ es2 ^ ")")
end
| Orelse_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.boolTy);
- unify state (pos, ty2, BasicTypes.boolTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy);
(BasicTypes.boolTy, "(" ^ es1 ^ ") orelse (" ^ es2 ^ ")")
end
| Andalso_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.boolTy);
- unify state (pos, ty2, BasicTypes.boolTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy);
(BasicTypes.boolTy, "(" ^ es1 ^ ") andalso (" ^ es2 ^ ")")
end
| Plus_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.intTy, "(" ^ es1 ^ ") + (" ^ es2 ^ ")")
end
| Minus_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.intTy, "(" ^ es1 ^ ") - (" ^ es2 ^ ")")
end
| Times_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.intTy, "(" ^ es1 ^ ") * (" ^ es2 ^ ")")
end
| Divide_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.intTy, "(" ^ es1 ^ ") div (" ^ es2 ^ ")")
end
| Mod_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.intTy, "(" ^ es1 ^ ") mod (" ^ es2 ^ ")")
end
| Lt_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.boolTy, "(" ^ es1 ^ ") < (" ^ es2 ^ ")")
end
| Lte_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.boolTy, "(" ^ es1 ^ ") <= (" ^ es2 ^ ")")
end
| Gt_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.boolTy, "(" ^ es1 ^ ") > (" ^ es2 ^ ")")
end
| Gte_e (e1, e2) =>
val (ty1, es1) = xexp state e1
val (ty2, es2) = xexp state e2
in
- unify state (pos, ty1, BasicTypes.intTy);
- unify state (pos, ty2, BasicTypes.intTy);
+ unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+ unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
(BasicTypes.boolTy, "(" ^ es1 ^ ") >= (" ^ es2 ^ ")")
end
| Param_e => (BasicTypes.--> (BasicTypes.stringTy, BasicTypes.stringTy), "Web.getParam")
fun toUpper ch = chr (ord ch + ord #"A" - ord #"a")
val name = str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE)
in
- (templateTy, "(Web.withParams " ^ name ^ ".exec)")
+ (templateTy, "(Web.withParams " ^ name ^ "_.exec)")
end
else
(error (SOME pos, "Unknown template " ^ name);
val (ty1, s1) = xexp state e1
val (ty2, s2) = xexp state e2
in
- unify state (pos, ty1, ty2);
- unify state (pos, ty1, newTyvar true);
+ unify state (pos, ExpUn e1, ty1, ty2);
+ unify state (pos, ExpUn e2, ty1, newTyvar true);
(BasicTypes.boolTy, "(" ^ s1 ^ ") = (" ^ s2 ^ ")")
end
| Neq_e (e1, e2) =>
val (ty1, s1) = xexp state e1
val (ty2, s2) = xexp state e2
in
- unify state (pos, ty1, ty2);
- unify state (pos, ty1, newTyvar true);
+ unify state (pos, ExpUn e1, ty1, ty2);
+ unify state (pos, ExpUn e2, ty1, newTyvar true);
(BasicTypes.boolTy, "(" ^ s1 ^ ") <> (" ^ s2 ^ ")")
end
| Ident_e [] => raise Fail "Impossible empty variable path"
let
val (ft, fs) = xexp state f
val (xt, xs) = xexp state x
-
- (*val (ft, _) = TypesUtil.instantiatePoly ft*)
- val dom = domain ft
- val ran = range ft
in
- unify state (pos, dom, xt);
- (ran, "(" ^ fs ^ ") (" ^ xs ^ ")")
+ if BasicTypes.isArrowType ft then
+ (unify state (pos, ExpUn x, domain ft, xt);
+ (range ft, "(" ^ fs ^ ") (" ^ xs ^ ")"))
+ else
+ (error (SOME pos, "Applying non-function");
+ (errorTy, "<error>"))
end
+ | Case_e (e, matches) =>
+ let
+ val (ty, s) = xexp state e
+
+ fun folder ((p, e'), (first, str, bodyTy)) =
+ let
+ val (pty, vars', ps) = xpat state p
+
+ val _ = unify state (pos, ExpUn e, ty, pty)
+
+ val (ty', str') = xexp (addVars (state, vars')) e'
+ in
+ unify state (pos, ExpUn e', ty', bodyTy);
+ (false,
+ str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^
+ str' ^ "\n",
+ bodyTy)
+ end
+ val bodyTy = newTyvar false
+ val (_, str, _) =
+ foldl folder (true, "(case (" ^ s ^ ") of\n", bodyTy) matches
+ val str = str ^ ")\n"
+ in
+ (bodyTy, str)
+ end
| Record_e (ist, cs) =>
let
val (cs, str) = foldl (fn ((id, e), (cs, str)) =>
in
(BasicTypes.recordTy cs, str)
end
+ | Fn_e matches =>
+ let
+ val dom = newTyvar false
+ val ran = newTyvar false
+
+ fun folder ((p, e'), (first, str)) =
+ let
+ val (pty, vars', ps) = xpat state p
+
+ val _ = unify state (pos, ExpUn exp, dom, pty)
+
+ val (ty', str') = xexp (addVars (state, vars')) e'
+ in
+ unify state (pos, ExpUn e', ty', ran);
+ (false,
+ str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^
+ str' ^ "\n")
+ end
+ val (_, str) =
+ foldl folder (true, "(fn \n") matches
+ val str = str ^ ")\n"
+ in
+ (BasicTypes.--> (dom, ran), str)
+ end
+ | Raise_e e =>
+ let
+ val (ty, es) = xexp state e
+ in
+ unify state (pos, ExpUn e, ty, BasicTypes.exnTy);
+ (newTyvar false, "(raise (" ^ es ^ "))")
+ end
+ | Let_e (b, e) =>
+ let
+ val (state, str) = xblock state b
+ val (ty, es) = xexp state e
+ in
+ (ty, "let\n" ^ str ^ "\nin\n" ^ es ^ "\nend\n")
+ end
+ | If_e (c, t, e) =>
+ let
+ val (bty, ce) = xexp state c
+ val (ty, te) = xexp state t
+ val (ty', ee) = xexp state e
+ in
+ unify state (pos, ExpUn c, bty, BasicTypes.boolTy);
+ unify state (pos, ExpUn exp, ty, ty');
+ (ty, "(if (" ^ ce ^ ") then (" ^ te ^ ") else (" ^ ee ^ "))")
+ end
| RecordUpd_e (e, cs) =>
let
val (ty, es) = xexp state e
let
val (ty', s) = xexp state e
in
- unify state (pos, ty, ty');
+ unify state (pos, ExpUn e, ty, ty');
(n + 1, str ^ ", " ^ Symbol.name id ^ " = " ^ s)
end) (0, "") cs'
end)
handle Skip => (errorTy, "<error>")
- fun mergePatVars pos (vars1, vars2) =
+ and mergePatVars pos (vars1, vars2) =
StringMap.foldli (fn (v, ty, vars) =>
(case StringMap.find (vars, v) of
NONE => StringMap.insert (vars, v, ty)
| SOME _ => error (SOME pos, "Duplicate variable " ^ v ^ " in pattern"))) vars1 vars2
- fun xpat state (PAT (p, pos)) =
+ and xpat state (pat as PAT (p, pos)) =
(case p of
Ident_p [] => raise Fail "Impossible empty Ident_p"
| Ident_p [id] =>
(resolveCon (pos, state, path), StringMap.empty, foldl (fn (v, st) => st ^ "." ^ v) s rest)
| Wild_p => (newTyvar false, StringMap.empty, "_")
| Int_p n => (BasicTypes.intTy, StringMap.empty, Int.toString n)
+ | Real_p n => (BasicTypes.realTy, StringMap.empty, Real.toString n)
| String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"")
+ | Char_p s => (BasicTypes.charTy, StringMap.empty, "#\"" ^ s ^ "\"")
| App_p ([], _) => raise Fail "Impossible App_p"
| App_p ([id], p) =>
let
val tyc = lookCon (state, id, pos)
val dom = domain tyc
in
- unify state (pos, dom, ty);
+ unify state (pos, PatUn p, dom, ty);
(range tyc, vars, id ^ " (" ^ s ^ ")")
end
| App_p (path as (fst::rest), p) =>
val tyc = resolveCon (pos, state, path)
val dom = domain tyc
in
- unify state (pos, dom, ty);
+ unify state (pos, PatUn p, dom, ty);
(range tyc, vars, foldl (fn (n, st) => st ^ "." ^ n) fst rest ^ " (" ^ s ^ ")")
end
| Cons_p (p1, p2) =>
val resty = Types.CONty (BasicTypes.listTycon, [ty1])
in
- unify state (pos, ty2, resty);
+ unify state (pos, PatUn pat, ty2, resty);
(resty, mergePatVars pos (vars', vars''), "(" ^ s1 ^ ")::(" ^ s2 ^ ")")
end
| As_p (id, p) =>
error (SOME pos, "Not done yet!!!")*))
handle Skip => (errorTy, StringMap.empty, "<error>")
- fun xblock state (BLOCK (blocks, pos)) =
+ and xblock state (BLOCK (blocks, pos)) =
let
fun folder (BITEM (bi, pos), (state, str)) =
(case bi of
val (ty, es) = xexp state e
in
- unify state (pos, ty, vty);
+ unify state (pos, ExpUn e, ty, vty);
(state, str ^ "val _ = " ^ id ^ " := (" ^ es ^ ")\n")
end
| Val_i (p, e) =>
val state' = addVars (state, vars)
val (ty, es) = xexp state e
in
- unify state (pos, pty, ty);
+ unify state (pos, ExpUn e, pty, ty);
(state', str ^ "val " ^ ps ^ " = (" ^ es ^ ")\n")
end
| Exp_i e =>
in
(state, str ^ "val _ = " ^ printFn ^ " (" ^ s ^ ")\n")
end
- | Ifthenelse_i (ifs, els) =>
+ | Ifthenelse_i (e, b, els) =>
let
val str = str ^ "val _ = "
- fun folder ((e, b), (first, str)) =
- let
- val (ty, s) = xexp state e
- val (_, str') = xblock state b
- in
- unify state (pos, ty, BasicTypes.boolTy);
- (false, str ^ (if first then "" else "else ") ^ "if (" ^ s ^ ") then let\n" ^
- str' ^
- "in () end\n")
- end
- val (_, str) = foldl folder (true, str) ifs
+ val (ty, s) = xexp state e
+ val (_, str') = xblock state b
+ val _ = unify state (pos, ExpUn e, ty, BasicTypes.boolTy)
+ val str = str ^ "if (" ^ s ^ ") then let\n" ^
+ str' ^
+ "in () end\n"
val str =
case els of
NONE =>
in
(state, str)
end
- | Foreach_i (id, e, b) =>
+ | Foreach_i (p, e, b) =>
let
val parm = newTyvar false
-
+
+ val (pty, vars, ps) = xpat state p
val (ty, es) = xexp state e
- val _ = unify state (pos, ty, Types.CONty (BasicTypes.listTycon, [parm]))
-
- (*val _ = print ("... to " ^ tyToString (context, ivmap, pty) ^ "\n")*)
+ val _ = unify state (pos, ExpUn e, ty, Types.CONty (BasicTypes.listTycon, [parm]))
+ val _ = unify state (pos, PatUn p, pty, parm)
- val state = addVar (state, id, VAR parm)
- val (_, bs) = xblock state b
- in
- (state, str ^ "fun foreach (" ^ id ^ (*" : " ^
- Elab.tyToString (context, ivmap, pty) ^*) ") = let\n" ^
+ val state' = addVars (state, vars)
+ val (_, bs) = xblock state' b
+ in
+ (state, str ^ "fun foreach ((" ^ ps ^ ") : " ^
+ tyToString state parm ^ ") = let\n" ^
bs ^
"in () end\n" ^
"val _ = app foreach (" ^ es ^ ")\n")
| For_i (id, eFrom, eTo, b) =>
let
val (ty1, es1) = xexp state eFrom
- val _ = unify state (pos, ty1, BasicTypes.intTy)
+ val _ = unify state (pos, ExpUn eFrom, ty1, BasicTypes.intTy)
val (ty2, es2) = xexp state eTo
- val _ = unify state (pos, ty2, BasicTypes.intTy)
+ val _ = unify state (pos, ExpUn eTo, ty2, BasicTypes.intTy)
val state = addVar (state, id, VAR BasicTypes.intTy)
val (_, bs) = xblock state b
(state, str ^ "fun forFunc " ^ id ^ " = let\n" ^
bs ^
"in () end\n" ^
- "val _ = for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n")
+ "val _ = Web.for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n")
end
| Case_i (e, matches) =>
let
let
val (pty, vars', ps) = xpat state p
- val _ = unify state (pos, ty, pty)
+ val _ = unify state (pos, PatUn p, ty, pty)
val (_, str') = xblock (addVars (state, vars')) b
val state = addVars (state, vars)
val (_, str') = xblock state b
in
- unify state (pos, BasicTypes.exnTy, pty);
+ unify state (pos, PatUn p, BasicTypes.exnTy, pty);
(false,
str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => let\n" ^
str' ^
HCoop / bpt / mlt.git / blobdiff