adam@1856: (* Copyright (c) 2013, Adam Chlipala
adam@1856:  * All rights reserved.
adam@1856:  *
adam@1856:  * Redistribution and use in source and binary forms, with or without
adam@1856:  * modification, are permitted provided that the following conditions are met:
adam@1856:  *
adam@1856:  * - Redistributions of source code must retain the above copyright notice,
adam@1856:  *   this list of conditions and the following disclaimer.
adam@1856:  * - Redistributions in binary form must reproduce the above copyright notice,
adam@1856:  *   this list of conditions and the following disclaimer in the documentation
adam@1856:  *   and/or other materials provided with the distribution.
adam@1856:  * - The names of contributors may not be used to endorse or promote products
adam@1856:  *   derived from this software without specific prior written permission.
adam@1856:  *
adam@1856:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adam@1856:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adam@1856:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adam@1856:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adam@1856:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adam@1856:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adam@1856:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adam@1856:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adam@1856:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adam@1856:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adam@1856:  * POSSIBILITY OF SUCH DAMAGE.
adam@1856:  *)
adam@1856: 
adam@1856: structure SigCheck :> SIG_CHECK = struct
adam@1856: 
adam@1856: open Mono
adam@1856: 
adam@1856: structure IS = IntBinarySet
adam@1856: structure E = ErrorMsg
adam@1856: 
adam@1856: fun check (ds, sl) =
adam@1856:     let
adam@1856:         fun isSiggy siggers =
adam@1856:             MonoUtil.Decl.exists {typ = fn _ => false,
adam@1856:                                   decl = fn _ => false,
adam@1856:                                   exp = fn e =>
adam@1856:                                         case e of
adam@1856:                                             ERel n => IS.member (siggers, n)
adam@1856:                                           | EFfiApp ("Basis", "sigString", _) => true
adam@1856:                                           | _ => false}
adam@1856: 
adam@1856:         fun sigify' sigdecs e =
adam@1856:             case e of
adam@1856:                 ENamed n => if IS.member (sigdecs, n) then
adam@1856:                                 (EApp ((e, E.dummySpan),
adam@1856:                                        (ERecord [], E.dummySpan)))
adam@1856:                             else
adam@1856:                                 e
adam@1856:               | _ => e
adam@1856: 
adam@1856:         fun sigify sigdecs =
adam@1856:             MonoUtil.Decl.map {typ = fn x => x,
adam@1856:                                decl = fn d => d,
adam@1856:                                exp = sigify' sigdecs}
adam@1856: 
adam@1856:         fun sigifyE sigdecs =
adam@1856:             MonoUtil.Exp.map {typ = fn x => x,
adam@1856:                               exp = sigify' sigdecs}
adam@1856: 
adam@1856:         fun isFun (e, _) =
adam@1856:             case e of
adam@1856:                 EAbs _ => true
adam@1856:               | _ => false
adam@1856: 
adam@1856:         fun doDecl (d : decl, (siggers, sigdecs)) =
adam@1856:             case #1 d of
adam@1856:                 DVal (x, n, t, e, s) =>
adam@1856:                 if isSiggy siggers d then
adam@1856:                     if isFun e then
adam@1856:                         (sigify sigdecs d, (IS.add (siggers, n), sigdecs))
adam@1856:                     else
adam@1856:                         ((DVal (x, n, (TFun ((TRecord [], #2 d), t), #2 d),
adam@1856:                                 (EAbs ("_", (TRecord [], #2 d), t, sigifyE sigdecs e), #2 d),
adam@1856:                                 s), #2 d),
adam@1856:                          (IS.add (siggers, n),
adam@1856:                           IS.add (sigdecs, n)))
adam@1856:                 else
adam@1856:                     (sigify sigdecs d, (siggers, sigdecs))
adam@1856:               | DValRec vis =>
adam@1856:                 if isSiggy siggers d then
adam@1856:                     (sigify sigdecs d,
adam@1856:                      (foldl IS.add' siggers (map #2 vis),
adam@1856:                       sigdecs))
adam@1856:                 else
adam@1856:                     (sigify sigdecs d, (siggers, sigdecs))
adam@1856:               | _ => (sigify sigdecs d, (siggers, sigdecs))
adam@1856: 
adam@1856:         val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) ds
adam@1856:     in
adam@1856:         (ds, sl)
adam@1856:     end
adam@1856: 
adam@1856: end