Mercurial > urweb
diff src/corify.sml @ 1125:e06bfeb6c2aa
Supporting any number of arguments for explicitly exported functions
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 12 Jan 2010 10:33:03 -0500 |
| parents | e1d738870086 |
| children | c01fb6f1b31f |
line wrap: on
line diff
--- a/src/corify.sml Tue Jan 12 09:58:14 2010 -0500 +++ b/src/corify.sml Tue Jan 12 10:33:03 2010 -0500 @@ -963,50 +963,63 @@ fun wrapSgi ((sgi, _), (wds, eds)) = case sgi of - L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) => - (case #1 ran of - L.CApp ((L.CModProj (basis, [], "transaction"), _), - ran' as - (L.CApp - ((L.CApp - ((L.CApp ((L.CModProj (basis', [], "xml"), _), - (L.CRecord (_, [((L.CName "Html", _), - _)]), _)), _), _), - _), _), _)) => - let - val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) - val ranT = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), - ran), loc) - val e = (L.EModProj (m, ms, s), loc) + L.SgiVal (s, _, t) => + let + fun getPage (t, args) = + case #1 t of + L.CApp ((L.CModProj (basis, [], "transaction"), _), + t' as + (L.CApp + ((L.CApp + ((L.CApp ((L.CModProj (basis', [], "xml"), _), + (L.CRecord (_, [((L.CName "Html", _), + _)]), _)), _), _), + _), _), _)) => + if basis = basis_n andalso basis' = basis_n then + SOME (t', rev args) + else + NONE + | L.TFun (dom, ran) => getPage (ran, dom :: args) + | _ => NONE + in + case getPage (t, []) of + NONE => (wds, eds) + | SOME (ran', args) => + let + val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) + val ranT = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc), + ran), loc) + val e = (L.EModProj (m, ms, s), loc) - val ef = (L.EModProj (basis, [], "bind"), loc) - val ef = (L.ECApp (ef, (L.CModProj (basis, [], "transaction"), loc)), loc) - val ef = (L.ECApp (ef, ran'), loc) - val ef = (L.ECApp (ef, ran), loc) - val ef = (L.EApp (ef, (L.EModProj (basis, [], "transaction_monad"), loc)), loc) - val ef = (L.EApp (ef, (L.EApp (e, (L.ERel 0, loc)), loc)), loc) + val ef = (L.EModProj (basis_n, [], "bind"), loc) + val ef = (L.ECApp (ef, (L.CModProj (basis_n, [], "transaction"), loc)), loc) + val ef = (L.ECApp (ef, ran'), loc) + val ef = (L.ECApp (ef, ran), loc) + val ef = (L.EApp (ef, (L.EModProj (basis_n, [], "transaction_monad"), loc)), + loc) + val ea = ListUtil.foldri (fn (i, _, ea) => + (L.EApp (ea, (L.ERel i, loc)), loc)) e args + val ef = (L.EApp (ef, ea), loc) - val eat = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), - ran), loc) - val ea = (L.EAbs ("p", ran', eat, - (L.EWrite (L.ERel 0, loc), loc)), loc) + val eat = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc), + ran), loc) + val ea = (L.EAbs ("p", ran', eat, + (L.EWrite (L.ERel 0, loc), loc)), loc) - val e = (L.EApp (ef, ea), loc) - val e = (L.EAbs ("vs", dom, ran, e), loc) - in - if basis = basis_n andalso basis' = basis_n then - ((L.DVal ("wrap_" ^ s, 0, - (L.TFun (dom, ranT), loc), - e), loc) :: wds, - (fn st => - case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of - L'.ENamed n => (L'.DExport (L'.Link, n, false), loc) - | _ => raise Fail "Corify: Value to export didn't corify properly") - :: eds) - else - (wds, eds) - end - | _ => (wds, eds)) + val (e, tf) = ListUtil.foldri (fn (i, t, (e, tf)) => + ((L.EAbs ("x" ^ Int.toString i, + t, tf, e), loc), + (L.TFun (t, tf), loc))) + ((L.EApp (ef, ea), loc), ranT) args + in + ((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds, + (fn st => + case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of + L'.ENamed n => (L'.DExport (L'.Link, n, false), loc) + | _ => raise Fail "Corify: Value to export didn't corify properly") + :: eds) + end + end | _ => (wds, eds) val (wds, eds) = foldl wrapSgi ([], []) sgis