Mercurial > urweb
changeset 794:dc3fc3f3b834
Improving/reordering Unpoly and Especialize; pathmaps
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 14 May 2009 08:13:54 -0400 |
| parents | 3e5d1c6ae30c |
| children | b87e71e45536 |
| files | lib/ur/list.ur lib/ur/list.urs src/compiler.sig src/compiler.sml src/especialize.sml src/jscomp.sml src/unpoly.sml src/urweb.grm tests/pathmap.ur tests/pathmap.urp |
| diffstat | 10 files changed, 488 insertions(+), 338 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/ur/list.ur Thu May 14 08:13:54 2009 -0400 @@ -0,0 +1,31 @@ +datatype t = datatype Basis.list + +val show (a ::: Type) (_ : show a) = + let + fun show' (ls : list a) = + case ls of + [] => "[]" + | x :: ls => show x ^ " :: " ^ show' ls + in + mkShow show' + end + +val rev (a ::: Type) = + let + fun rev' acc (ls : list a) = + case ls of + [] => acc + | x :: ls => rev' (x :: acc) ls + in + rev' [] + end + +fun mp (a ::: Type) (b ::: Type) f = + let + fun mp' acc ls = + case ls of + [] => rev acc + | x :: ls => mp' (f x :: acc) ls + in + mp' [] + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/ur/list.urs Thu May 14 08:13:54 2009 -0400 @@ -0,0 +1,8 @@ +datatype t = datatype Basis.list + +val show : a ::: Type -> show a -> show (list a) + +val rev : a ::: Type -> t a -> t a + +val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b +
--- a/src/compiler.sig Tue May 12 20:15:11 2009 -0400 +++ b/src/compiler.sig Thu May 14 08:13:54 2009 -0400 @@ -77,7 +77,6 @@ val termination : (Elab.file, Elab.file) phase val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase - val especialize : (Core.file, Core.file) phase val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase val rpcify : (Core.file, Core.file) phase @@ -107,7 +106,6 @@ val toTermination : (string, Elab.file) transform val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform - val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform val toRpcify : (string, Core.file) transform @@ -118,6 +116,8 @@ val toUnpoly : (string, Core.file) transform val toSpecialize : (string, Core.file) transform val toShake3 : (string, Core.file) transform + val toEspecialize : (string, Core.file) transform + val toShake4 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform val toEffectize : (string, Core.file) transform val toMonoize : (string, Mono.file) transform
--- a/src/compiler.sml Tue May 12 20:15:11 2009 -0400 +++ b/src/compiler.sml Thu May 14 08:13:54 2009 -0400 @@ -267,276 +267,313 @@ s end -fun parseUrp' filename = +structure M = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +fun parseUrp' fname = let - val dir = OS.Path.dir filename - val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) + val pathmap = ref (M.insert (M.empty, "", Config.libUr)) - fun relify fname = - OS.Path.concat (dir, fname) - handle OS.Path.Path => fname + fun pu filename = + let + val dir = OS.Path.dir filename + val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) - val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} + fun pathify fname = + if size fname > 0 andalso String.sub (fname, 0) = #"$" then + let + val fname' = Substring.extract (fname, 1, NONE) + val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname' + in + if Substring.isEmpty after then + fname + else + case M.find (!pathmap, Substring.string befor) of + NONE => fname + | SOME rep => rep ^ Substring.string after + end + else + fname - fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir} + fun relify fname = + let + val fname = pathify fname + in + OS.Path.concat (dir, fname) + handle OS.Path.Path => fname + end - fun readSources acc = - case TextIO.inputLine inf of - NONE => rev acc - | SOME line => - let - val acc = if CharVector.all Char.isSpace line then - acc - else - let - val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) - (String.explode line)) - val fname = relify fname - in - fname :: acc - end - in - readSources acc - end + val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} - val prefix = ref NONE - val database = ref NONE - val exe = ref NONE - val sql = ref NONE - val debug = ref false - val profile = ref false - val timeout = ref NONE - val ffi = ref [] - val link = ref [] - val headers = ref [] - val scripts = ref [] - val clientToServer = ref [] - val effectful = ref [] - val clientOnly = ref [] - val serverOnly = ref [] - val jsFuncs = ref [] - val rewrites = ref [] - val url = ref [] - val mime = ref [] - val libs = ref [] + fun relifyA fname = + OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} - fun finish sources = - let - val job = { - prefix = Option.getOpt (!prefix, "/"), - database = !database, - exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, - ext = SOME "exe"}), - sql = !sql, - debug = !debug, - profile = !profile, - timeout = Option.getOpt (!timeout, 60), - ffi = rev (!ffi), - link = rev (!link), - headers = rev (!headers), - scripts = rev (!scripts), - clientToServer = rev (!clientToServer), - effectful = rev (!effectful), - clientOnly = rev (!clientOnly), - serverOnly = rev (!serverOnly), - jsFuncs = rev (!jsFuncs), - rewrites = rev (!rewrites), - filterUrl = rev (!url), - filterMime = rev (!mime), - sources = sources - } + fun readSources acc = + case TextIO.inputLine inf of + NONE => rev acc + | SOME line => + let + val acc = if CharVector.all Char.isSpace line then + acc + else + let + val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) + (String.explode line)) + val fname = relify fname + in + fname :: acc + end + in + readSources acc + end - fun mergeO f (old, new) = - case (old, new) of - (NONE, _) => new - | (_, NONE) => old - | (SOME v1, SOME v2) => SOME (f (v1, v2)) + val prefix = ref NONE + val database = ref NONE + val exe = ref NONE + val sql = ref NONE + val debug = ref false + val profile = ref false + val timeout = ref NONE + val ffi = ref [] + val link = ref [] + val headers = ref [] + val scripts = ref [] + val clientToServer = ref [] + val effectful = ref [] + val clientOnly = ref [] + val serverOnly = ref [] + val jsFuncs = ref [] + val rewrites = ref [] + val url = ref [] + val mime = ref [] + val libs = ref [] - fun same desc = mergeO (fn (x : string, y) => - (if x = y then - () - else - ErrorMsg.error ("Multiple " - ^ desc ^ " values that don't agree"); - x)) + fun finish sources = + let + val job = { + prefix = Option.getOpt (!prefix, "/"), + database = !database, + exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, + ext = SOME "exe"}), + sql = !sql, + debug = !debug, + profile = !profile, + timeout = Option.getOpt (!timeout, 60), + ffi = rev (!ffi), + link = rev (!link), + headers = rev (!headers), + scripts = rev (!scripts), + clientToServer = rev (!clientToServer), + effectful = rev (!effectful), + clientOnly = rev (!clientOnly), + serverOnly = rev (!serverOnly), + jsFuncs = rev (!jsFuncs), + rewrites = rev (!rewrites), + filterUrl = rev (!url), + filterMime = rev (!mime), + sources = sources + } - fun merge (old : job, new : job) = { - prefix = #prefix old, - database = #database old, - exe = #exe old, - sql = #sql old, - debug = #debug old orelse #debug new, - profile = #profile old orelse #profile new, - timeout = #timeout old, - ffi = #ffi old @ #ffi new, - link = #link old @ #link new, - headers = #headers old @ #headers new, - scripts = #scripts old @ #scripts new, - clientToServer = #clientToServer old @ #clientToServer new, - effectful = #effectful old @ #effectful new, - clientOnly = #clientOnly old @ #clientOnly new, - serverOnly = #serverOnly old @ #serverOnly new, - jsFuncs = #jsFuncs old @ #jsFuncs new, - rewrites = #rewrites old @ #rewrites new, - filterUrl = #filterUrl old @ #filterUrl new, - filterMime = #filterMime old @ #filterMime new, - sources = #sources new @ #sources old - } + fun mergeO f (old, new) = + case (old, new) of + (NONE, _) => new + | (_, NONE) => old + | (SOME v1, SOME v2) => SOME (f (v1, v2)) + + fun same desc = mergeO (fn (x : string, y) => + (if x = y then + () + else + ErrorMsg.error ("Multiple " + ^ desc ^ " values that don't agree"); + x)) + + fun merge (old : job, new : job) = { + prefix = #prefix old, + database = #database old, + exe = #exe old, + sql = #sql old, + debug = #debug old orelse #debug new, + profile = #profile old orelse #profile new, + timeout = #timeout old, + ffi = #ffi old @ #ffi new, + link = #link old @ #link new, + headers = #headers old @ #headers new, + scripts = #scripts old @ #scripts new, + clientToServer = #clientToServer old @ #clientToServer new, + effectful = #effectful old @ #effectful new, + clientOnly = #clientOnly old @ #clientOnly new, + serverOnly = #serverOnly old @ #serverOnly new, + jsFuncs = #jsFuncs old @ #jsFuncs new, + rewrites = #rewrites old @ #rewrites new, + filterUrl = #filterUrl old @ #filterUrl new, + filterMime = #filterMime old @ #filterMime new, + sources = #sources new @ #sources old + } + in + foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs) + end + + fun parsePkind s = + case s of + "all" => Settings.Any + | "url" => Settings.Url + | "table" => Settings.Table + | "sequence" => Settings.Sequence + | "view" => Settings.View + | "relation" => Settings.Relation + | "cookie" => Settings.Cookie + | "style" => Settings.Style + | _ => (ErrorMsg.error "Bad path kind spec"; + Settings.Any) + + fun parseFrom s = + if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then + (Settings.Prefix, String.substring (s, 0, size s - 1)) + else + (Settings.Exact, s) + + fun parseFkind s = + case s of + "url" => url + | "mime" => mime + | _ => (ErrorMsg.error "Bad filter kind"; + url) + + fun parsePattern s = + if size s > 0 andalso String.sub (s, size s - 1) = #"*" then + (Settings.Prefix, String.substring (s, 0, size s - 1)) + else + (Settings.Exact, s) + + fun read () = + case TextIO.inputLine inf of + NONE => finish [] + | SOME "\n" => finish (readSources []) + | SOME line => + let + val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) + val cmd = Substring.string (trim cmd) + val arg = Substring.string (trim arg) + + fun ffiS () = + case String.fields (fn ch => ch = #".") arg of + [m, x] => (m, x) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); + ("", "")) + + fun ffiM () = + case String.fields (fn ch => ch = #"=") arg of + [f, s] => + (case String.fields (fn ch => ch = #".") f of + [m, x] => ((m, x), s) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); + (("", ""), ""))) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); + (("", ""), "")) + in + case cmd of + "prefix" => + (case !prefix of + NONE => () + | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; + prefix := SOME arg) + | "database" => + (case !database of + NONE => () + | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; + database := SOME arg) + | "exe" => + (case !exe of + NONE => () + | SOME _ => ErrorMsg.error "Duplicate 'exe' directive"; + exe := SOME (relify arg)) + | "sql" => + (case !sql of + NONE => () + | SOME _ => ErrorMsg.error "Duplicate 'sql' directive"; + sql := SOME (relify arg)) + | "debug" => debug := true + | "profile" => profile := true + | "timeout" => + (case !timeout of + NONE => () + | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; + timeout := SOME (valOf (Int.fromString arg))) + | "ffi" => ffi := relify arg :: !ffi + | "link" => link := relifyA arg :: !link + | "include" => headers := relifyA arg :: !headers + | "script" => scripts := arg :: !scripts + | "clientToServer" => clientToServer := ffiS () :: !clientToServer + | "effectful" => effectful := ffiS () :: !effectful + | "clientOnly" => clientOnly := ffiS () :: !clientOnly + | "serverOnly" => serverOnly := ffiS () :: !serverOnly + | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs + | "rewrite" => + let + fun doit (pkind, from, to) = + let + val pkind = parsePkind pkind + val (kind, from) = parseFrom from + in + rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites + end + in + case String.tokens Char.isSpace arg of + [pkind, from, to] => doit (pkind, from, to) + | [pkind, from] => doit (pkind, from, "") + | _ => ErrorMsg.error "Bad 'rewrite' syntax" + end + | "allow" => + (case String.tokens Char.isSpace arg of + [fkind, pattern] => + let + val fkind = parseFkind fkind + val (kind, pattern) = parsePattern pattern + in + fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind + end + | _ => ErrorMsg.error "Bad 'allow' syntax") + | "deny" => + (case String.tokens Char.isSpace arg of + [fkind, pattern] => + let + val fkind = parseFkind fkind + val (kind, pattern) = parsePattern pattern + in + fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind + end + | _ => ErrorMsg.error "Bad 'deny' syntax") + | "library" => libs := relify arg :: !libs + | "path" => + (case String.fields (fn ch => ch = #"=") arg of + [n, v] => pathmap := M.insert (!pathmap, n, v) + | _ => ErrorMsg.error "path argument not of the form name=value'") + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); + read () + end + + val job = read () in - foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs) + TextIO.closeIn inf; + Settings.setUrlPrefix (#prefix job); + Settings.setTimeout (#timeout job); + Settings.setHeaders (#headers job); + Settings.setScripts (#scripts job); + Settings.setClientToServer (#clientToServer job); + Settings.setEffectful (#effectful job); + Settings.setClientOnly (#clientOnly job); + Settings.setServerOnly (#serverOnly job); + Settings.setJsFuncs (#jsFuncs job); + Settings.setRewriteRules (#rewrites job); + Settings.setUrlRules (#filterUrl job); + Settings.setMimeRules (#filterMime job); + job end - - fun parsePkind s = - case s of - "all" => Settings.Any - | "url" => Settings.Url - | "table" => Settings.Table - | "sequence" => Settings.Sequence - | "view" => Settings.View - | "relation" => Settings.Relation - | "cookie" => Settings.Cookie - | "style" => Settings.Style - | _ => (ErrorMsg.error "Bad path kind spec"; - Settings.Any) - - fun parseFrom s = - if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then - (Settings.Prefix, String.substring (s, 0, size s - 1)) - else - (Settings.Exact, s) - - fun parseFkind s = - case s of - "url" => url - | "mime" => mime - | _ => (ErrorMsg.error "Bad filter kind"; - url) - - fun parsePattern s = - if size s > 0 andalso String.sub (s, size s - 1) = #"*" then - (Settings.Prefix, String.substring (s, 0, size s - 1)) - else - (Settings.Exact, s) - - fun read () = - case TextIO.inputLine inf of - NONE => finish [] - | SOME "\n" => finish (readSources []) - | SOME line => - let - val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) - val cmd = Substring.string (trim cmd) - val arg = Substring.string (trim arg) - - fun ffiS () = - case String.fields (fn ch => ch = #".") arg of - [m, x] => (m, x) - | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); - ("", "")) - - fun ffiM () = - case String.fields (fn ch => ch = #"=") arg of - [f, s] => - (case String.fields (fn ch => ch = #".") f of - [m, x] => ((m, x), s) - | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); - (("", ""), ""))) - | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); - (("", ""), "")) - in - case cmd of - "prefix" => - (case !prefix of - NONE => () - | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; - prefix := SOME arg) - | "database" => - (case !database of - NONE => () - | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; - database := SOME arg) - | "exe" => - (case !exe of - NONE => () - | SOME _ => ErrorMsg.error "Duplicate 'exe' directive"; - exe := SOME (relify arg)) - | "sql" => - (case !sql of - NONE => () - | SOME _ => ErrorMsg.error "Duplicate 'sql' directive"; - sql := SOME (relify arg)) - | "debug" => debug := true - | "profile" => profile := true - | "timeout" => - (case !timeout of - NONE => () - | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; - timeout := SOME (valOf (Int.fromString arg))) - | "ffi" => ffi := relify arg :: !ffi - | "link" => link := relifyA arg :: !link - | "include" => headers := relifyA arg :: !headers - | "script" => scripts := arg :: !scripts - | "clientToServer" => clientToServer := ffiS () :: !clientToServer - | "effectful" => effectful := ffiS () :: !effectful - | "clientOnly" => clientOnly := ffiS () :: !clientOnly - | "serverOnly" => serverOnly := ffiS () :: !serverOnly - | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs - | "rewrite" => - let - fun doit (pkind, from, to) = - let - val pkind = parsePkind pkind - val (kind, from) = parseFrom from - in - rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites - end - in - case String.tokens Char.isSpace arg of - [pkind, from, to] => doit (pkind, from, to) - | [pkind, from] => doit (pkind, from, "") - | _ => ErrorMsg.error "Bad 'rewrite' syntax" - end - | "allow" => - (case String.tokens Char.isSpace arg of - [fkind, pattern] => - let - val fkind = parseFkind fkind - val (kind, pattern) = parsePattern pattern - in - fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind - end - | _ => ErrorMsg.error "Bad 'allow' syntax") - | "deny" => - (case String.tokens Char.isSpace arg of - [fkind, pattern] => - let - val fkind = parseFkind fkind - val (kind, pattern) = parsePattern pattern - in - fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind - end - | _ => ErrorMsg.error "Bad 'deny' syntax") - | "library" => libs := relify arg :: !libs - | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); - read () - end - - val job = read () in - TextIO.closeIn inf; - Settings.setUrlPrefix (#prefix job); - Settings.setTimeout (#timeout job); - Settings.setHeaders (#headers job); - Settings.setScripts (#scripts job); - Settings.setClientToServer (#clientToServer job); - Settings.setEffectful (#effectful job); - Settings.setClientOnly (#clientOnly job); - Settings.setServerOnly (#serverOnly job); - Settings.setJsFuncs (#jsFuncs job); - Settings.setRewriteRules (#rewrites job); - Settings.setUrlRules (#filterUrl job); - Settings.setMimeRules (#filterMime job); - job + pu fname end val parseUrp = { @@ -669,14 +706,12 @@ print = CorePrint.p_file CoreEnv.empty } -val toEspecialize = transform especialize "especialize" o toCorify - val core_untangle = { func = CoreUntangle.untangle, print = CorePrint.p_file CoreEnv.empty } -val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize +val toCore_untangle = transform core_untangle "core_untangle" o toCorify val shake = { func = Shake.shake, @@ -725,12 +760,16 @@ val toShake3 = transform shake "shake3" o toSpecialize +val toEspecialize = transform especialize "especialize" o toShake3 + +val toShake4 = transform shake "shake4" o toEspecialize + val marshalcheck = { func = (fn file => (MarshalCheck.check file; file)), print = CorePrint.p_file CoreEnv.empty } -val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake3 +val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake4 val effectize = { func = Effective.effectize,
--- a/src/especialize.sml Tue May 12 20:15:11 2009 -0400 +++ b/src/especialize.sml Thu May 14 08:13:54 2009 -0400 @@ -148,6 +148,13 @@ val functionInside = U.Con.exists {kind = fn _ => false, con = fn TFun _ => true | CFfi ("Basis", "transaction") => true + | CFfi ("Basis", "eq") => true + | CFfi ("Basis", "num") => true + | CFfi ("Basis", "ord") => true + | CFfi ("Basis", "show") => true + | CFfi ("Basis", "read") => true + | CFfi ("Basis", "sql_injectable_prim") => true + | CFfi ("Basis", "sql_injectable") => true | _ => false} val loc = ErrorMsg.dummySpan
--- a/src/jscomp.sml Tue May 12 20:15:11 2009 -0400 +++ b/src/jscomp.sml Thu May 14 08:13:54 2009 -0400 @@ -400,6 +400,8 @@ else s + val foundJavaScript = ref false + fun jsExp mode skip outer = let val len = length outer @@ -662,8 +664,10 @@ let val args = case (m, x, args) of - ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e] - | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] + ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => + (foundJavaScript := true; [e]) + | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => + (foundJavaScript := true; [e1, e2]) | _ => args val name = case Settings.jsFunc (m, x) of @@ -871,12 +875,15 @@ str ")"], st) end - | EJavaScript (Source _, _, SOME _) => (e, st) + | EJavaScript (Source _, _, SOME _) => + (foundJavaScript := true; + (e, st)) | EJavaScript (_, _, SOME e) => - (strcat [str "cs(function(){return ", - e, - str "})"], - st) + (foundJavaScript := true; + (strcat [str "cs(function(){return ", + e, + str "})"], + st)) | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" @@ -888,6 +895,7 @@ let val (e, st) = jsE inner (e, st) in + foundJavaScript := true; (strcat [str "cs(function(){return ", e, str "})"], @@ -995,7 +1003,8 @@ in case e of EJavaScript (m, orig, NONE) => - doCode m 0 env orig orig + (foundJavaScript := true; + doCode m 0 env orig orig) | _ => (e, st) end, decl = fn (_, e, st) => (e, st), @@ -1031,9 +1040,15 @@ NONE => String.concat (rev acc) | SOME line => lines (line :: acc) val lines = lines [] + + val script = + if !foundJavaScript then + lines ^ String.concat (rev (#script st)) + else + "" in TextIO.closeIn inf; - (DJavaScript (lines ^ String.concat (rev (#script st))), ErrorMsg.dummySpan) :: ds + (DJavaScript script, ErrorMsg.dummySpan) :: ds end end
--- a/src/unpoly.sml Tue May 12 20:15:11 2009 -0400 +++ b/src/unpoly.sml Thu May 14 08:13:54 2009 -0400 @@ -72,8 +72,19 @@ end | _ => e} +structure M = BinaryMapFn(struct + type ord_key = con list + val compare = Order.joinL U.Con.compare + end) + +type func = { + kinds : kind list, + defs : (string * int * con * exp * string) list, + replacements : int M.map +} + type state = { - funcs : (kind list * (string * int * con * exp * string) list) IM.map, + funcs : func IM.map, decls : decl list, nextName : int } @@ -86,8 +97,6 @@ case e of ECApp _ => let - (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) - fun unravel (e, cargs) = case e of ECApp ((e, _), c) => unravel (e, c :: cargs) @@ -102,72 +111,101 @@ else case IM.find (#funcs st, n) of NONE => (e, st) - | SOME (ks, vis) => - let - val (vis, nextName) = ListUtil.foldlMap - (fn ((x, n, t, e, s), nextName) => - ((x, nextName, n, t, e, s), nextName + 1)) - (#nextName st) vis + | SOME {kinds = ks, defs = vis, replacements} => + case M.find (replacements, cargs) of + SOME n => (ENamed n, st) + | NONE => + let + val old_vis = vis + val (vis, (thisName, nextName)) = + ListUtil.foldlMap + (fn ((x, n', t, e, s), (thisName, nextName)) => + ((x, nextName, n', t, e, s), + (if n' = n then nextName else thisName, + nextName + 1))) + (0, #nextName st) vis - fun specialize (x, n, n_old, t, e, s) = - let - fun trim (t, e, cargs) = - case (t, e, cargs) of - ((TCFun (_, _, t), _), - (ECAbs (_, _, e), _), - carg :: cargs) => - let - val t = subConInCon (length cargs, carg) t - val e = subConInExp (length cargs, carg) e - in - trim (t, e, cargs) - end - | (_, _, []) => - let - val e = foldl (fn ((_, n, n_old, _, _, _), e) => - unpolyNamed (n_old, ENamed n) e) - e vis - in - SOME (t, e) - end - | _ => NONE - in - (*Print.prefaces "specialize" - [("t", CorePrint.p_con CoreEnv.empty t), - ("e", CorePrint.p_exp CoreEnv.empty e), - ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*) - Option.map (fn (t, e) => (x, n, n_old, t, e, s)) - (trim (t, e, cargs)) - end + fun specialize (x, n, n_old, t, e, s) = + let + fun trim (t, e, cargs) = + case (t, e, cargs) of + ((TCFun (_, _, t), _), + (ECAbs (_, _, e), _), + carg :: cargs) => + let + val t = subConInCon (length cargs, carg) t + val e = subConInExp (length cargs, carg) e + in + trim (t, e, cargs) + end + | (_, _, []) => + (*let + val e = foldl (fn ((_, n, n_old, _, _, _), e) => + unpolyNamed (n_old, ENamed n) e) + e vis + in*) + SOME (t, e) + (*end*) + | _ => NONE + in + (*Print.prefaces "specialize" + [("t", CorePrint.p_con CoreEnv.empty t), + ("e", CorePrint.p_exp CoreEnv.empty e), + ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*) + Option.map (fn (t, e) => (x, n, n_old, t, e, s)) + (trim (t, e, cargs)) + end - val vis = List.map specialize vis - in - if List.exists (not o Option.isSome) vis orelse length cargs > length ks then - (e, st) - else - let - val vis = List.mapPartial (fn x => x) vis - val vis = map (fn (x, n, n_old, t, e, s) => - (x ^ "_unpoly", n, n_old, t, e, s)) vis - val vis' = map (fn (x, n, _, t, e, s) => - (x, n, t, e, s)) vis + val vis = List.map specialize vis + in + if List.exists (not o Option.isSome) vis orelse length cargs > length ks then + (e, st) + else + let + val vis = List.mapPartial (fn x => x) vis - val ks' = List.drop (ks, length cargs) - in - case List.find (fn (_, _, n_old, _, _, _) => n_old = n) vis of - NONE => raise Fail "Unpoly: Inconsistent 'val rec' record" - | SOME (_, n, _, _, _, _) => - (ENamed n, - {funcs = foldl (fn (vi, funcs) => - IM.insert (funcs, #2 vi, (ks', vis'))) - (#funcs st) vis', + val vis = map (fn (x, n, n_old, t, e, s) => + (x ^ "_unpoly", n, n_old, t, e, s)) vis + val vis' = map (fn (x, n, _, t, e, s) => + (x, n, t, e, s)) vis + + val funcs = IM.insert (#funcs st, n, + {kinds = ks, + defs = old_vis, + replacements = M.insert (replacements, + cargs, + thisName)}) + + val ks' = List.drop (ks, length cargs) + + val st = {funcs = foldl (fn (vi, funcs) => + IM.insert (funcs, #2 vi, + {kinds = ks', + defs = vis', + replacements = M.empty})) + funcs vis', + decls = #decls st, + nextName = nextName} + + val (vis', st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => + let + val (e, st) = polyExp (e, st) + in + ((x, n, t, e, s), st) + end) + st vis' + in + (ENamed thisName, + {funcs = #funcs st, decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st, - nextName = nextName}) - end - end + nextName = #nextName st}) + end + end end | _ => (e, st) +and polyExp (x, st) = U.Exp.foldMap {kind = kind, con = con, exp = exp} st x + fun decl (d, st : state) = case d of DValRec (vis as ((x, n, t, e, s) :: rest)) => @@ -232,7 +270,9 @@ (d, st) else (d, {funcs = foldl (fn (vi, funcs) => - IM.insert (funcs, #2 vi, (cargs, vis))) + IM.insert (funcs, #2 vi, {kinds = cargs, + defs = vis, + replacements = M.empty})) (#funcs st) vis, decls = #decls st, nextName = #nextName st})
--- a/src/urweb.grm Tue May 12 20:15:11 2009 -0400 +++ b/src/urweb.grm Thu May 14 08:13:54 2009 -0400 @@ -933,12 +933,12 @@ | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right))) - | eterm DCOLON eexp (let - val loc = s (etermleft, eexpright) + | eapps DCOLON eexp (let + val loc = s (eappsleft, eexpright) in (EApp ((EVar (["Basis"], "Cons", Infer), loc), (ERecord [((CName "1", loc), - eterm), + eapps), ((CName "2", loc), eexp)], loc)), loc) end)