Mercurial > urweb

comparison src/corify.sml @ 1125:e06bfeb6c2aa

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
1124:2f53e0deffb3 1125:e06bfeb6c2aa
961 NONE => raise Fail "Corify: Don't know number of Basis" 961 NONE => raise Fail "Corify: Don't know number of Basis"
962 | SOME n => n 962 | SOME n => n
963 963
964 fun wrapSgi ((sgi, _), (wds, eds)) = 964 fun wrapSgi ((sgi, _), (wds, eds)) =
965 case sgi of 965 case sgi of
966 L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) => 966 L.SgiVal (s, _, t) =>
967 (case #1 ran of 967 let
968 L.CApp ((L.CModProj (basis, [], "transaction"), _), 968 fun getPage (t, args) =
969 ran' as 969 case #1 t of
970 (L.CApp 970 L.CApp ((L.CModProj (basis, [], "transaction"), _),
971 ((L.CApp 971 t' as
972 ((L.CApp ((L.CModProj (basis', [], "xml"), _), 972 (L.CApp
973 (L.CRecord (_, [((L.CName "Html", _), 973 ((L.CApp
974 _)]), _)), _), _), 974 ((L.CApp ((L.CModProj (basis', [], "xml"), _),
975 _), _), _)) => 975 (L.CRecord (_, [((L.CName "Html", _),
976 let 976 _)]), _)), _), _),
977 val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) 977 _), _), _)) =>
978 val ranT = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), 978 if basis = basis_n andalso basis' = basis_n then
979 ran), loc) 979 SOME (t', rev args)
980 val e = (L.EModProj (m, ms, s), loc) 980 else
981 981 NONE
982 val ef = (L.EModProj (basis, [], "bind"), loc) 982 | L.TFun (dom, ran) => getPage (ran, dom :: args)
983 val ef = (L.ECApp (ef, (L.CModProj (basis, [], "transaction"), loc)), loc) 983 | _ => NONE
984 val ef = (L.ECApp (ef, ran'), loc) 984 in
985 val ef = (L.ECApp (ef, ran), loc) 985 case getPage (t, []) of
986 val ef = (L.EApp (ef, (L.EModProj (basis, [], "transaction_monad"), loc)), loc) 986 NONE => (wds, eds)
987 val ef = (L.EApp (ef, (L.EApp (e, (L.ERel 0, loc)), loc)), loc) 987 | SOME (ran', args) =>
988 988 let
989 val eat = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), 989 val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc)
990 ran), loc) 990 val ranT = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc),
991 val ea = (L.EAbs ("p", ran', eat, 991 ran), loc)
992 (L.EWrite (L.ERel 0, loc), loc)), loc) 992 val e = (L.EModProj (m, ms, s), loc)
993 993
994 val e = (L.EApp (ef, ea), loc) 994 val ef = (L.EModProj (basis_n, [], "bind"), loc)
995 val e = (L.EAbs ("vs", dom, ran, e), loc) 995 val ef = (L.ECApp (ef, (L.CModProj (basis_n, [], "transaction"), loc)), loc)
996 in 996 val ef = (L.ECApp (ef, ran'), loc)
997 if basis = basis_n andalso basis' = basis_n then 997 val ef = (L.ECApp (ef, ran), loc)
998 ((L.DVal ("wrap_" ^ s, 0, 998 val ef = (L.EApp (ef, (L.EModProj (basis_n, [], "transaction_monad"), loc)),
999 (L.TFun (dom, ranT), loc), 999 loc)
1000 e), loc) :: wds, 1000 val ea = ListUtil.foldri (fn (i, _, ea) =>
1001 (fn st => 1001 (L.EApp (ea, (L.ERel i, loc)), loc)) e args
1002 case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of 1002 val ef = (L.EApp (ef, ea), loc)
1003 L'.ENamed n => (L'.DExport (L'.Link, n, false), loc) 1003
1004 | _ => raise Fail "Corify: Value to export didn't corify properly") 1004 val eat = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc),
1005 :: eds) 1005 ran), loc)
1006 else 1006 val ea = (L.EAbs ("p", ran', eat,
1007 (wds, eds) 1007 (L.EWrite (L.ERel 0, loc), loc)), loc)
1008 end 1008
1009 | _ => (wds, eds)) 1009 val (e, tf) = ListUtil.foldri (fn (i, t, (e, tf)) =>
1010 ((L.EAbs ("x" ^ Int.toString i,
1011 t, tf, e), loc),
1012 (L.TFun (t, tf), loc)))
1013 ((L.EApp (ef, ea), loc), ranT) args
1014 in
1015 ((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds,
1016 (fn st =>
1017 case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of
1018 L'.ENamed n => (L'.DExport (L'.Link, n, false), loc)
1019 | _ => raise Fail "Corify: Value to export didn't corify properly")
1020 :: eds)
1021 end
1022 end
1010 | _ => (wds, eds) 1023 | _ => (wds, eds)
1011 1024
1012 val (wds, eds) = foldl wrapSgi ([], []) sgis 1025 val (wds, eds) = foldl wrapSgi ([], []) sgis
1013 val wrapper = (L.StrConst wds, loc) 1026 val wrapper = (L.StrConst wds, loc)
1014 val mst = St.lookupStrById st m 1027 val mst = St.lookupStrById st m