Mercurial > urweb
changeset 110:3739af9e727a
Starting with closure links
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 13 Jul 2008 11:43:57 -0400 |
| parents | 813e5a52063d |
| children | 2d6116de9cca |
| files | lib/basis.lig src/compiler.sig src/compiler.sml src/core.sml src/core_print.sml src/core_util.sig src/core_util.sml src/corify.sml src/elab_print.sml src/elaborate.sml src/lacweb.grm src/lacweb.lex src/list_util.sig src/list_util.sml src/monoize.sml src/sources src/tag.sig src/tag.sml tests/link.lac |
| diffstat | 19 files changed, 312 insertions(+), 10 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/basis.lig Sun Jul 13 10:17:06 2008 -0400 +++ b/lib/basis.lig Sun Jul 13 11:43:57 2008 -0400 @@ -20,6 +20,8 @@ -> xml (shared ++ ctx1) -> xml (shared ++ ctx2) -> xml shared +con xhtml = xml [Html] + val head : tag [] [Html] [Head] val title : tag [] [Head] [] @@ -28,3 +30,5 @@ val b : tag [] [Body] [Body] val i : tag [] [Body] [Body] val font : tag [Size = int, Face = string] [Body] [Body] + +val a : tag [Link = xhtml] [Body] [Body]
--- a/src/compiler.sig Sun Jul 13 10:17:06 2008 -0400 +++ b/src/compiler.sig Sun Jul 13 11:43:57 2008 -0400 @@ -43,6 +43,7 @@ val explify : job -> Expl.file option val corify : job -> Core.file option val shake' : job -> Core.file option + val tag : job -> Core.file option val reduce : job -> Core.file option val shake : job -> Core.file option val monoize : job -> Mono.file option @@ -54,6 +55,7 @@ val testExplify : job -> unit val testCorify : job -> unit val testShake' : job -> unit + val testTag : job -> unit val testReduce : job -> unit val testShake : job -> unit val testMonoize : job -> unit
--- a/src/compiler.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/compiler.sml Sun Jul 13 11:43:57 2008 -0400 @@ -196,8 +196,17 @@ else SOME (Shake.shake file) +fun tag job = + case shake' job of + NONE => NONE + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else + SOME (Tag.tag file) + fun reduce job = - case corify job of + case tag job of NONE => NONE | SOME file => if ErrorMsg.anyErrors () then @@ -285,6 +294,15 @@ handle CoreEnv.UnboundNamed n => print ("Unbound named " ^ Int.toString n ^ "\n") +fun testTag job = + (case tag job of + NONE => print "Failed\n" + | SOME file => + (Print.print (CorePrint.p_file CoreEnv.empty file); + print "\n")) + handle CoreEnv.UnboundNamed n => + print ("Unbound named " ^ Int.toString n ^ "\n") + fun testReduce job = (case reduce job of NONE => print "Failed\n"
--- a/src/core.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/core.sml Sun Jul 13 11:43:57 2008 -0400 @@ -76,6 +76,8 @@ | EWrite of exp + | EClosure of int * exp list + withtype exp = exp' located datatype decl' =
--- a/src/core_print.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/core_print.sml Sun Jul 13 11:43:57 2008 -0400 @@ -232,6 +232,12 @@ p_exp env e, string ")"] + | EClosure (n, es) => box [string "CLOSURE(", + p_enamed env n, + p_list_sep (string "") (fn e => box [string ", ", + p_exp env e]) es, + string ")"] + and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) =
--- a/src/core_util.sig Sun Jul 13 10:17:06 2008 -0400 +++ b/src/core_util.sig Sun Jul 13 11:43:57 2008 -0400 @@ -121,6 +121,12 @@ exp : Core.exp' * 'state -> 'state, decl : Core.decl' * 'state -> 'state} -> 'state -> Core.decl -> 'state + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state, + decl : Core.decl' * 'state -> Core.decl' * 'state} + -> 'state -> Core.decl -> Core.decl * 'state end structure File : sig @@ -151,6 +157,12 @@ exp : Core.exp' * 'state -> 'state, decl : Core.decl' * 'state -> 'state} -> 'state -> Core.file -> 'state + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state, + decl : Core.decl' * 'state -> Core.decl' * 'state} + -> 'state -> Core.file -> Core.file * 'state end end
--- a/src/core_util.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/core_util.sml Sun Jul 13 11:43:57 2008 -0400 @@ -291,6 +291,11 @@ S.map2 (mfe ctx e, fn e' => (EWrite e', loc)) + + | EClosure (n, es) => + S.map2 (ListUtil.mapfold (mfe ctx) es, + fn es' => + (EClosure (n, es'), loc)) in mfe end @@ -401,6 +406,14 @@ S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.Decl.fold: Impossible" +fun foldMap {kind, con, exp, decl} s d = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible" + end structure File = struct @@ -456,6 +469,14 @@ S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.File.fold: Impossible" +fun foldMap {kind, con, exp, decl} s d = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.File.foldMap: Impossible" + end end
--- a/src/corify.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/corify.sml Sun Jul 13 11:43:57 2008 -0400 @@ -358,7 +358,8 @@ | L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc) | L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc) - | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) + | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => + (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) | L.EFold k => (L'.EFold (corifyKind k), loc) @@ -450,8 +451,8 @@ (case (#1 dom, #1 ran) of (L.TRecord _, L.CApp ((L.CModProj (_, [], "xml"), _), - (L.TRecord (L.CRecord (_, [((L.CName "Html", _), - _)]), _), _))) => + (L.CRecord (_, [((L.CName "Html", _), + _)]), _))) => let val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) val e = (L.EModProj (m, ms, s), loc)
--- a/src/elab_print.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/elab_print.sml Sun Jul 13 11:43:57 2008 -0400 @@ -451,6 +451,7 @@ space, p_con env c2] | DExport (_, sgn, str) => box [string "export", + space, p_str env str, space, string ":",
--- a/src/elaborate.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/elaborate.sml Sun Jul 13 11:43:57 2008 -0400 @@ -1945,13 +1945,12 @@ (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of (((L'.TRecord domR, _), []), ((L'.CApp (tf, ranR), _), [])) => - (case hnormCon (env, denv) ranR of - (ranR, []) => + (case (hnormCon (env, denv) tf, hnormCon (env, denv) ranR) of + ((tf, []), (ranR, [])) => (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of ((domR, []), (ranR, [])) => (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc), - (L'.CApp (tf, - (L'.TRecord ranR, loc)), loc)), + (L'.CApp (tf, ranR), loc)), loc)), loc) | _ => all) | _ => all)
--- a/src/lacweb.grm Sun Jul 13 10:17:06 2008 -0400 +++ b/src/lacweb.grm Sun Jul 13 11:43:57 2008 -0400 @@ -281,6 +281,7 @@ | path (EVar path, s (pathleft, pathright)) | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) + | UNIT (ERecord [], s (UNITleft, UNITright)) | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) @@ -345,3 +346,4 @@ attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | LBRACE eexp RBRACE (eexp)
--- a/src/lacweb.lex Sun Jul 13 10:17:06 2008 -0400 +++ b/src/lacweb.lex Sun Jul 13 11:43:57 2008 -0400 @@ -227,8 +227,10 @@ <INITIAL> ")" => (Tokens.RPAREN (pos yypos, pos yypos + size yytext)); <INITIAL> "[" => (Tokens.LBRACK (pos yypos, pos yypos + size yytext)); <INITIAL> "]" => (Tokens.RBRACK (pos yypos, pos yypos + size yytext)); -<INITIAL> "{" => (Tokens.LBRACE (pos yypos, pos yypos + size yytext)); -<INITIAL> "}" => (Tokens.RBRACE (pos yypos, pos yypos + size yytext)); +<INITIAL> "{" => (enterBrace (); + Tokens.LBRACE (pos yypos, pos yypos + size yytext)); +<INITIAL> "}" => (exitBrace (); + Tokens.RBRACE (pos yypos, pos yypos + size yytext)); <INITIAL> "->" => (Tokens.ARROW (pos yypos, pos yypos + size yytext)); <INITIAL> "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext));
--- a/src/list_util.sig Sun Jul 13 10:17:06 2008 -0400 +++ b/src/list_util.sig Sun Jul 13 11:43:57 2008 -0400 @@ -27,6 +27,8 @@ signature LIST_UTIL = sig + val mapConcat : ('a -> 'b list) -> 'a list -> 'b list + val mapfold : ('data, 'state, 'abort) Search.mapfolder -> ('data list, 'state, 'abort) Search.mapfolder val mapfoldB : ('context * 'data -> 'context * ('state -> ('data * 'state, 'abort) Search.result))
--- a/src/list_util.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/list_util.sml Sun Jul 13 11:43:57 2008 -0400 @@ -29,6 +29,16 @@ structure S = Search +fun mapConcat f = + let + fun mc acc ls = + case ls of + [] => rev acc + | h :: t => mc (List.revAppend (f h, acc)) t + in + mc [] + end + fun mapfold f = let fun mf ls s =
--- a/src/monoize.sml Sun Jul 13 10:17:06 2008 -0400 +++ b/src/monoize.sml Sun Jul 13 11:43:57 2008 -0400 @@ -192,6 +192,8 @@ | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc) | L.EFold _ => poly () | L.EWrite e => (L'.EWrite (monoExp env e), loc) + + | L.EClosure _ => raise Fail "Monoize EClosure" end fun monoDecl env (all as (d, loc)) =
--- a/src/sources Sun Jul 13 10:17:06 2008 -0400 +++ b/src/sources Sun Jul 13 11:43:57 2008 -0400 @@ -75,6 +75,9 @@ shake.sig shake.sml +tag.sig +tag.sml + mono.sml mono_util.sig
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tag.sig Sun Jul 13 11:43:57 2008 -0400 @@ -0,0 +1,32 @@ +(* 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. + *) + +signature TAG = sig + + val tag : Core.file -> Core.file + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tag.sml Sun Jul 13 11:43:57 2008 -0400 @@ -0,0 +1,174 @@ +(* 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 Tag :> TAG = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IM = IntBinaryMap + +fun kind (k, s) = (k, s) +fun con (c, s) = (c, s) + +fun exp (e, s) = + case e of + EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + attrs), _), + tag), _), + xml) => + (case attrs of + (ERecord xets, _) => + let + val (xets, s) = + ListUtil.foldlMap (fn ((x, e, t), (count, tags, newTags)) => + case x of + (CName "Link", _) => + let + fun unravel (e, _) = + case e of + ENamed n => (n, []) + | EApp (e1, e2) => + let + val (n, es) = unravel e1 + in + (n, es @ [e2]) + end + | _ => (ErrorMsg.errorAt loc "Invalid link expression"; + (0, [])) + + val (f, args) = unravel e + + val (cn, count, tags, newTags) = + case IM.find (tags, f) of + NONE => + (count, count + 1, IM.insert (tags, f, count), + (f, count) :: newTags) + | SOME cn => (cn, count, tags, newTags) + + val e = (EClosure (cn, args), loc) + val t = (CFfi ("Basis", "string"), loc) + in + ((x, e, t), + (count, tags, newTags)) + end + | _ => ((x, e, t), (count, tags, newTags))) + s xets + in + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + (ERecord xets, loc)), loc), + tag), loc), + xml), s) + end + | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; + (e, s))) + + | _ => (e, s) + +fun decl (d, s) = (d, s) + +fun tag file = + let + val count = foldl (fn ((d, _), count) => + case d of + DCon (_, n, _, _) => Int.max (n, count) + | DVal (_, n, _, _, _) => Int.max (n, count) + | DExport _ => count) 0 file + + fun doDecl (d as (d', loc), (env, count, tags)) = + let + val (d, (count, tags, newTags)) = + U.Decl.foldMap {kind = kind, + con = con, + exp = exp, + decl = decl} + (count, tags, []) d + + val env = E.declBinds env d + + val newDs = ListUtil.mapConcat + (fn (f, cn) => + let + fun unravel (all as (t, _)) = + case t of + TFun (dom, ran) => + let + val (args, result) = unravel ran + in + (dom :: args, result) + end + | _ => ([], all) + + val (fnam, t, _, tag) = E.lookupENamed env f + val (args, result) = unravel t + + val (app, _) = foldl (fn (t, (app, n)) => + ((EApp (app, (ERel n, loc)), loc), + n - 1)) + ((ENamed f, loc), length args - 1) args + val body = (EWrite app, loc) + val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) + val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => + ((EAbs ("x" ^ Int.toString n, + t, + rest, + abs), loc), + n + 1, + (TFun (t, rest), loc))) + (body, 0, unit) args + in + [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc), + (DExport cn, loc)] + end) newTags + in + (newDs @ [d], (env, count, tags)) + end + + val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file + in + file + end + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/link.lac Sun Jul 13 11:43:57 2008 -0400 @@ -0,0 +1,9 @@ +val ancillary : {} -> xhtml = fn () => <html> + Welcome to the ancillary page! +</html> + +val main : {} -> xhtml = fn () => <html><body> + <a link={ancillary ()}>Enter the unknown!</a> + + <a link={ancillary ()}>Alternate route!</a> +</body></html>