addNum (1, L)
end
+fun compact' [] = []
+ | compact' (BITEM (Html_i h1, p1) :: BITEM (Html_i h2, p2) :: rest) = compact' (BITEM (Html_i (h1 ^ h2), p1) :: rest)
+ | compact' (first :: rest) = first :: compact' rest
+
+fun compact (BLOCK (items, pos)) = BLOCK (compact' items, pos)
%%
%header (functor MltLrValsFn(structure Token : TOKEN))
%term
EOF
| HTML of string
- | IF | THEN | ELSE
+ | IF | THEN | ELSE | ELSEIF | IFF
| AS | WITH | OPEN | VAL | REF | TRY | CATCH
- | FN | END | RAISE
- | FOREACH | IN | DO
+ | FN | LET | IN | END | RAISE
+ | FOREACH | FOR | DO
| SWITCH | CASE | OF | BAR | ARROW
- | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | HASH | SEMI | CONS
+ | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | HASH | SEMI | CONS | O
| PLUS | MINUS | TIMES | DIVIDE | MOD | NEG | DOLLAR | AT | STRCAT
| ASN | EQ | NEQ | GT | GTE | LT | LTE
| ANDALSO | ORELSE
%%
-file : block (block)
+file : block (compact block)
ilist : IDENT ilist (IDENT :: ilist)
| IDENT ([IDENT])
ivlist : IDENT EQ exp COMMA ivlist ((IDENT, exp) :: ivlist)
| IDENT EQ exp ([(IDENT, exp)])
-catch : pat ARROW block (pat, block)
+catch : pat ARROW block (pat, compact block)
catches : catches BAR catch (catch::catches)
| catch ([catch])
| IDENT ASN exp (BITEM (Assn_i (IDENT, exp), (IDENTleft, expright)))
| exp (BITEM (Exp_i exp, (expleft, expright)))
| IF exp THEN block elseOpt END
- (BITEM (Ifthenelse_i(exp, block, elseOpt),
+ (BITEM (Ifthenelse_i(exp, compact block, elseOpt),
(IFleft, ENDright)))
- | FOREACH IDENT IN exp DO block END
- (BITEM (Foreach_i (IDENT, exp, block),
+ | FOREACH pat IN exp DO block END
+ (BITEM (Foreach_i (pat, exp, compact block),
(FOREACHleft, ENDright)))
- | FOREACH IDENT IN exp DOTDOT exp DO block END
- (BITEM (For_i (IDENT, exp1, exp2, block),
- (FOREACHleft, ENDright)))
+ | FOR IDENT IN exp DOTDOT exp DO block END
+ (BITEM (For_i (IDENT, exp1, exp2, compact block),
+ (FORleft, ENDright)))
| SWITCH exp OF matches END
(BITEM (Case_i (exp, List.rev (#1 matches)), (SWITCHleft, ENDright)))
| TRY block WITH catches END
- (BITEM (TryCatch_i (block, List.rev catches), (TRYleft, ENDright)))
+ (BITEM (TryCatch_i (compact block, List.rev catches), (TRYleft, ENDright)))
-elseOpt : (NONE)
- | ELSE block (SOME block)
+elseOpt : (NONE)
+ | ELSEIF exp THEN block elseOpt (SOME (BLOCK ([BITEM (Ifthenelse_i (exp, compact block, elseOpt),
+ (ELSEIFleft, elseOptright))],
+ (ELSEIFleft, elseOptright))))
+ | ELSE block (SOME (compact block))
block : blockItem (BLOCK ([blockItem], (blockItemleft, blockItemright)))
| blockItem SEMI block (BLOCK (blockItem :: (unblock block), (blockItemleft, blockright)))
| exp GT exp (EXP (Gt_e (exp1, exp2), (exp1left, exp2right)))
| exp GTE exp (EXP (Gte_e (exp1, exp2), (exp1left, exp2right)))
| exp CONS exp (EXP (Cons_e (exp1, exp2), (exp1left, exp2right)))
+ | exp O exp (EXP (Compose_e (exp1, exp2), (exp1left, exp2right)))
| exp STRCAT exp (EXP (StrCat_e (exp1, exp2), (exp1left, exp2right)))
| exp ORELSE exp (EXP (Orelse_e (exp1, exp2), (exp1left, exp2right)))
| exp ANDALSO exp (EXP (Andalso_e (exp1, exp2), (exp1left, exp2right)))
| CASE exp OF cases (EXP (Case_e (exp, List.rev cases), (expleft, casesright)))
| FN cases (EXP (Fn_e (List.rev cases), (FNleft, casesright)))
| RAISE exp (EXP (Raise_e exp, (RAISEleft, expright)))
+ | LET block IN exp END (EXP (Let_e (compact block, exp), (LETleft, ENDright)))
+ | IFF exp THEN exp ELSE exp (EXP (If_e (exp1, exp2, exp3), (IFFleft, exp3right)))
cases : pat ARROW exp ([(pat, exp)])
| cases BAR pat ARROW exp ((pat, exp) :: cases)
-matches : matches BAR pat ARROW block (((pat, block) :: (#1 matches), (matchesleft, blockright)))
- | pat ARROW block ([(pat, block)], (patleft, blockright))
+matches : matches BAR pat ARROW block (((pat, compact block) :: (#1 matches), (matchesleft, blockright)))
+ | pat ARROW block ([(pat, compact block)], (patleft, blockright))
rseq : IDENT EQ pat COMMA rseq ((IDENT, pat) :: rseq)
| IDENT COMMA rseq ((IDENT, PAT (Ident_p [IDENT], (IDENTleft, IDENTright))) :: rseq)
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
datatype state = STATE of {env: StaticEnv.staticEnv,
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
PrettyPrint.end_block ppstream;
PrettyPrint.add_break ppstream (1, 0);
PrettyPrint.flush_ppstream ppstream;
- error (SOME pos, Unify.failMessage msg))
+ 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)
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
let
val (pty, vars', ps) = xpat state p
- val _ = unify state (pos, ty, pty)
+ val _ = unify state (pos, ExpUn e, ty, pty)
val (ty', str') = xexp (addVars (state, vars')) e'
in
- unify state (pos, ty', bodyTy);
+ unify state (pos, ExpUn e', ty', bodyTy);
(false,
str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^
str' ^ "\n",
let
val (pty, vars', ps) = xpat state p
- val _ = unify state (pos, dom, pty)
+ val _ = unify state (pos, ExpUn exp, dom, pty)
val (ty', str') = xexp (addVars (state, vars')) e'
in
- unify state (pos, ty', ran);
+ unify state (pos, ExpUn e', ty', ran);
(false,
str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^
str' ^ "\n")
let
val (ty, es) = xexp state e
in
- unify state (pos, ty, BasicTypes.exnTy);
+ 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'
NONE => StringMap.insert (vars, v, ty)
| SOME _ => error (SOME pos, "Duplicate variable " ^ v ^ " in pattern"))) vars1 vars2
- and 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] =>
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 =>
val str = str ^ "val _ = "
val (ty, s) = xexp state e
val (_, str') = xblock state b
- val _ = unify state (pos, ty, BasicTypes.boolTy)
+ val _ = unify state (pos, ExpUn e, ty, BasicTypes.boolTy)
val str = str ^ "if (" ^ s ^ ") then let\n" ^
str' ^
"in () end\n"
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 ^ " : " ^
+ 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" ^
| 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
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' ^