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@506:                 val (d, funcs, maxName) =
adamc@506:                     case #1 d of
adamc@506:                         DValRec vis =>
adamc@506:                         let
adamc@506:                             val (vis', funcs, maxName) =
adamc@506:                                 foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) =>
adamc@506:                                           case returnsString t of
adamc@506:                                               NONE => (vis', funcs, maxName)
adamc@506:                                             | SOME (args, t') =>
adamc@506:                                               let
adamc@506:                                                   fun getBody (e, args) =
adamc@506:                                                       case (#1 e, args) of
adamc@506:                                                           (_, []) => (e, [])
adamc@506:                                                         | (EAbs (x, t, _, e), _ :: args) =>
adamc@506:                                                           let
adamc@506:                                                               val (body, args') = getBody (e, args)
adamc@506:                                                           in
adamc@506:                                                               (body, (x, t) :: args')
adamc@506:                                                           end
adamc@506:                                                         | _ => raise Fail "Fuse: getBody"
adamc@506: 
adamc@506:                                                   val (body, args) = getBody (e, args)
adamc@506:                                                   val body = MonoOpt.optExp (EWrite body, loc)
adamc@814:                                                   val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
adamc@506:                                                                             ((EAbs (x, dom, ran, body), loc),
adamc@506:                                                                              (TFun (dom, ran), loc)))
adamc@506:                                                                         (body, (TRecord [], loc)) args
adamc@506:                                               in
adamc@506:                                                   ((x, maxName, t', body, s) :: vis',
adamc@506:                                                    IM.insert (funcs, n, maxName),
adamc@506:                                                    maxName + 1)
adamc@506:                                               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