Mercurial > urweb

annotate src/fuse.sml @ 835:b0a85cbefed2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Less whining about match failures; fix singleton record Jscomp bug
author Adam Chlipala <adamc@hcoop.net>
date Tue, 02 Jun 2009 12:40:09 -0400
parents 3f3b211f9bca
children 9304474170ed
rev   line source
adamc@506 1 (* Copyright (c) 2008, Adam Chlipala
adamc@506 2 * All rights reserved.
adamc@506 3 *
adamc@506 4 * Redistribution and use in source and binary forms, with or without
adamc@506 5 * modification, are permitted provided that the following conditions are met:
adamc@506 6 *
adamc@506 7 * - Redistributions of source code must retain the above copyright notice,
adamc@506 8 * this list of conditions and the following disclaimer.
adamc@506 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@506 10 * this list of conditions and the following disclaimer in the documentation
adamc@506 11 * and/or other materials provided with the distribution.
adamc@506 12 * - The names of contributors may not be used to endorse or promote products
adamc@506 13 * derived from this software without specific prior written permission.
adamc@506 14 *
adamc@506 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@506 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@506 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@506 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@506 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@506 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@506 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@506 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@506 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@506 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@506 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@506 26 *)
adamc@506 27
adamc@506 28 structure Fuse :> FUSE = struct
adamc@506 29
adamc@506 30 open Mono
adamc@506 31 structure U = MonoUtil
adamc@506 32
adamc@506 33 structure IM = IntBinaryMap
adamc@506 34
adamc@506 35 fun returnsString (t, loc) =
adamc@506 36 let
adamc@506 37 fun rs (t, loc) =
adamc@506 38 case t of
adamc@506 39 TFfi ("Basis", "string") => SOME ([], (TRecord [], loc))
adamc@506 40 | TFun (dom, ran) =>
adamc@506 41 (case rs ran of
adamc@506 42 NONE => NONE
adamc@506 43 | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
adamc@506 44 | _ => NONE
adamc@506 45 in
adamc@506 46 case t of
adamc@506 47 TFun (dom, ran) =>
adamc@506 48 (case rs ran of
adamc@506 49 NONE => NONE
adamc@506 50 | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
adamc@506 51 | _ => NONE
adamc@506 52 end
adamc@506 53
adamc@506 54 fun fuse file =
adamc@506 55 let
adamc@506 56 fun doDecl (d as (_, loc), (funcs, maxName)) =
adamc@506 57 let
adamc@506 58 val (d, funcs, maxName) =
adamc@506 59 case #1 d of
adamc@506 60 DValRec vis =>
adamc@506 61 let
adamc@506 62 val (vis', funcs, maxName) =
adamc@506 63 foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) =>
adamc@506 64 case returnsString t of
adamc@506 65 NONE => (vis', funcs, maxName)
adamc@506 66 | SOME (args, t') =>
adamc@506 67 let
adamc@506 68 fun getBody (e, args) =
adamc@506 69 case (#1 e, args) of
adamc@506 70 (_, []) => (e, [])
adamc@506 71 | (EAbs (x, t, _, e), _ :: args) =>
adamc@506 72 let
adamc@506 73 val (body, args') = getBody (e, args)
adamc@506 74 in
adamc@506 75 (body, (x, t) :: args')
adamc@506 76 end
adamc@506 77 | _ => raise Fail "Fuse: getBody"
adamc@506 78
adamc@506 79 val (body, args) = getBody (e, args)
adamc@506 80 val body = MonoOpt.optExp (EWrite body, loc)
adamc@814 81 val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
adamc@506 82 ((EAbs (x, dom, ran, body), loc),
adamc@506 83 (TFun (dom, ran), loc)))
adamc@506 84 (body, (TRecord [], loc)) args
adamc@506 85 in
adamc@506 86 ((x, maxName, t', body, s) :: vis',
adamc@506 87 IM.insert (funcs, n, maxName),
adamc@506 88 maxName + 1)
adamc@506 89 end)
adamc@506 90 ([], funcs, maxName) vis
adamc@506 91 in
adamc@506 92 ((DValRec (vis @ vis'), loc), funcs, maxName)
adamc@506 93 end
adamc@506 94 | _ => (d, funcs, maxName)
adamc@506 95
adamc@506 96 fun exp e =
adamc@506 97 case e of
adamc@506 98 EWrite e' =>
adamc@506 99 let
adamc@506 100 fun unravel (e, loc) =
adamc@506 101 case e of
adamc@506 102 ENamed n =>
adamc@506 103 (case IM.find (funcs, n) of
adamc@506 104 NONE => NONE
adamc@506 105 | SOME n' => SOME (ENamed n', loc))
adamc@506 106 | EApp (e1, e2) =>
adamc@506 107 (case unravel e1 of
adamc@506 108 NONE => NONE
adamc@506 109 | SOME e1 => SOME (EApp (e1, e2), loc))
adamc@506 110 | _ => NONE
adamc@506 111 in
adamc@506 112 case unravel e' of
adamc@506 113 NONE => e
adamc@506 114 | SOME (e', _) => e'
adamc@506 115 end
adamc@506 116 | _ => e
adamc@506 117 in
adamc@506 118 (U.Decl.map {typ = fn x => x,
adamc@506 119 exp = exp,
adamc@506 120 decl = fn x => x}
adamc@506 121 d,
adamc@506 122 (funcs, maxName))
adamc@506 123 end
adamc@506 124
adamc@506 125 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file
adamc@506 126 in
adamc@506 127 file
adamc@506 128 end
adamc@506 129
adamc@506 130 end