adamc@506: (* Copyright (c) 2008, Adam Chlipala adamc@506: * All rights reserved. adamc@506: * adamc@506: * Redistribution and use in source and binary forms, with or without adamc@506: * modification, are permitted provided that the following conditions are met: adamc@506: * adamc@506: * - Redistributions of source code must retain the above copyright notice, adamc@506: * this list of conditions and the following disclaimer. adamc@506: * - Redistributions in binary form must reproduce the above copyright notice, adamc@506: * this list of conditions and the following disclaimer in the documentation adamc@506: * and/or other materials provided with the distribution. adamc@506: * - The names of contributors may not be used to endorse or promote products adamc@506: * derived from this software without specific prior written permission. adamc@506: * adamc@506: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@506: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@506: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@506: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@506: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@506: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@506: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@506: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@506: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@506: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@506: * POSSIBILITY OF SUCH DAMAGE. adamc@506: *) adamc@506: adamc@506: structure Fuse :> FUSE = struct adamc@506: adamc@506: open Mono adamc@506: structure U = MonoUtil adamc@506: adamc@506: structure IM = IntBinaryMap adamc@506: adamc@506: fun returnsString (t, loc) = adamc@506: let adamc@506: fun rs (t, loc) = adamc@506: case t of adamc@506: TFfi ("Basis", "string") => SOME ([], (TRecord [], loc)) adamc@506: | TFun (dom, ran) => adamc@506: (case rs ran of adamc@506: NONE => NONE adamc@506: | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) adamc@506: | _ => NONE adamc@506: in adamc@506: case t of adamc@506: TFun (dom, ran) => adamc@506: (case rs ran of adamc@506: NONE => NONE adamc@506: | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) adamc@506: | _ => NONE adamc@506: end adamc@506: adamc@506: fun fuse file = adamc@506: let adamc@506: fun doDecl (d as (_, loc), (funcs, maxName)) = adamc@506: let adamc@1018: exception GetBody adamc@1018: adamc@1018: fun doVi ((x, n, t, e, s), funcs, maxName) = adamc@1018: case returnsString t of adamc@1018: NONE => (NONE, funcs, maxName) adamc@1018: | SOME (args, t') => adamc@1018: let adamc@1018: fun getBody (e, args) = adamc@1018: case (#1 e, args) of adamc@1018: (_, []) => (e, []) adamc@1018: | (EAbs (x, t, _, e), _ :: args) => adamc@1018: let adamc@1018: val (body, args') = getBody (e, args) adamc@1018: in adamc@1018: (body, (x, t) :: args') adamc@1018: end adamc@1018: | _ => raise GetBody adamc@1018: adamc@1018: val (body, args) = getBody (e, args) adamc@1018: val body = MonoOpt.optExp (EWrite body, loc) adamc@1018: val (body, _) = foldr (fn ((x, dom), (body, ran)) => adamc@1018: ((EAbs (x, dom, ran, body), loc), adamc@1018: (TFun (dom, ran), loc))) adamc@1018: (body, (TRecord [], loc)) args adamc@1018: in adamc@1018: (SOME (x, maxName, t', body, s), adamc@1018: IM.insert (funcs, n, maxName), adamc@1018: maxName + 1) adamc@1018: end adamc@1018: handle GetBody => (NONE, funcs, maxName) adamc@1018: adamc@506: val (d, funcs, maxName) = adamc@506: case #1 d of adamc@1018: DVal vi => adamc@1018: let adamc@1018: val (vi', funcs, maxName) = doVi (vi, funcs, maxName) adamc@1018: in adamc@1018: (case vi' of adamc@1018: NONE => d adamc@1018: | SOME vi' => (DValRec [vi, vi'], loc), adamc@1018: funcs, maxName) adamc@1018: end adamc@1018: | DValRec vis => adamc@506: let adamc@506: val (vis', funcs, maxName) = adamc@1018: foldl (fn (vi, (vis', funcs, maxName)) => adamc@1018: let adamc@1018: val (vi', funcs, maxName) = doVi (vi, funcs, maxName) adamc@1018: in adamc@1018: (case vi' of adamc@1018: NONE => vis' adamc@1018: | SOME vi' => vi' :: vis', adamc@1018: funcs, maxName) adamc@1018: end) adamc@506: ([], funcs, maxName) vis adamc@506: in adamc@506: ((DValRec (vis @ vis'), loc), funcs, maxName) adamc@506: end adamc@506: | _ => (d, funcs, maxName) adamc@506: adamc@506: fun exp e = adamc@506: case e of adamc@506: EWrite e' => adamc@506: let adamc@506: fun unravel (e, loc) = adamc@506: case e of adamc@506: ENamed n => adamc@506: (case IM.find (funcs, n) of adamc@506: NONE => NONE adamc@506: | SOME n' => SOME (ENamed n', loc)) adamc@506: | EApp (e1, e2) => adamc@506: (case unravel e1 of adamc@506: NONE => NONE adamc@506: | SOME e1 => SOME (EApp (e1, e2), loc)) adamc@506: | _ => NONE adamc@506: in adamc@506: case unravel e' of adamc@506: NONE => e adamc@506: | SOME (e', _) => e' adamc@506: end adamc@506: | _ => e adamc@506: in adamc@506: (U.Decl.map {typ = fn x => x, adamc@506: exp = exp, adamc@506: decl = fn x => x} adamc@506: d, adamc@506: (funcs, maxName)) adamc@506: end adamc@506: adamc@506: val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file adamc@506: in adamc@506: file adamc@506: end adamc@506: adamc@506: end