adamc@448: (* Copyright (c) 2008, Adam Chlipala
adamc@448:  * All rights reserved.
adamc@448:  *
adamc@448:  * Redistribution and use in source and binary forms, with or without
adamc@448:  * modification, are permitted provided that the following conditions are met:
adamc@448:  *
adamc@448:  * - Redistributions of source code must retain the above copyright notice,
adamc@448:  *   this list of conditions and the following disclaimer.
adamc@448:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@448:  *   this list of conditions and the following disclaimer in the documentation
adamc@448:  *   and/or other materials provided with the distribution.
adamc@448:  * - The names of contributors may not be used to endorse or promote products
adamc@448:  *   derived from this software without specific prior written permission.
adamc@448:  *
adamc@448:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@448:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@448:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@448:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@448:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@448:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@448:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@448:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@448:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@448:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@448:  * POSSIBILITY OF SUCH DAMAGE.
adamc@448:  *)
adamc@448: 
adamc@448: (* Remove nested function definitions *)
adamc@448: 
adamc@448: structure Unnest :> UNNEST = struct
adamc@448: 
adamc@448: open Elab
adamc@448: 
adamc@448: structure E = ElabEnv
adamc@448: structure U = ElabUtil
adamc@448: 
adamc@448: structure IS = IntBinarySet
adamc@448: 
adamc@487: fun liftExpInExp by =
adamc@623:     U.Exp.mapB {kind = fn _ => fn k => k,
adamc@487:                 con = fn _ => fn c => c,
adamc@487:                 exp = fn bound => fn e =>
adamc@487:                                      case e of
adamc@487:                                          ERel xn =>
adamc@487:                                          if xn < bound then
adamc@487:                                              e
adamc@487:                                          else
adamc@487:                                              ERel (xn + by)
adamc@487:                                        | _ => e,
adamc@487:                 bind = fn (bound, U.Exp.RelE _) => bound + 1
adamc@487:                         | (bound, _) => bound}
adamc@487: 
adamc@487: val subExpInExp =
adamc@623:     U.Exp.mapB {kind = fn _ => fn k => k,
adamc@487:                 con = fn _ => fn c => c,
adamc@487:                 exp = fn (xn, rep) => fn e =>
adamc@487:                                   case e of
adamc@487:                                       ERel xn' =>
adamc@487:                                       if xn' = xn then
adamc@487:                                            #1 rep
adamc@487:                                       else
adamc@487:                                           e
adamc@487:                                     | _ => e,
adamc@487:                 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, E.liftExpInExp 0 rep)
adamc@487:                         | ((xn, rep), U.Exp.RelC _) => (xn, E.liftConInExp 0 rep)
adamc@487:                         | (ctx, _) => ctx}
adamc@487: 
adamc@623: val fvsCon = U.Con.foldB {kind = fn (_, _, st) => st,
adamc@448:                           con = fn (cb, c, cvs) =>
adamc@448:                                    case c of
adamc@448:                                        CRel n =>
adamc@448:                                        if n >= cb then
adamc@448:                                            IS.add (cvs, n - cb)
adamc@448:                                        else
adamc@448:                                            cvs
adamc@448:                                      | _ => cvs,
adamc@448:                           bind = fn (cb, b) =>
adamc@448:                                     case b of
adamc@623:                                         U.Con.RelC _ => cb + 1
adamc@448:                                       | _ => cb}
adamc@448:                          0 IS.empty
adamc@448: 
adamc@623: fun fvsExp nr = U.Exp.foldB {kind = fn (_, _, st) => st,
adamc@448:                              con = fn ((cb, eb), c, st as (cvs, evs)) =>
adamc@448:                                       case c of
adamc@448:                                           CRel n =>
adamc@448:                                           if n >= cb then
adamc@448:                                               (IS.add (cvs, n - cb), evs)
adamc@448:                                           else
adamc@448:                                               st
adamc@448:                                         | _ => st,
adamc@448:                              exp = fn ((cb, eb), e, st as (cvs, evs)) =>
adamc@448:                                       case e of
adamc@448:                                           ERel n =>
adamc@448:                                           if n >= eb then
adamc@448:                                               (cvs, IS.add (evs, n - eb))
adamc@448:                                           else
adamc@448:                                               st
adamc@448:                                         | _ => st,
adamc@448:                              bind = fn (ctx as (cb, eb), b) =>
adamc@448:                                        case b of
adamc@448:                                            U.Exp.RelC _ => (cb + 1, eb)
adamc@448:                                          | U.Exp.RelE _ => (cb, eb + 1)
adamc@448:                                          | _ => ctx}
adamc@448:                             (0, nr) (IS.empty, IS.empty)
adamc@448: 
adamc@448: fun positionOf (x : int) ls =
adamc@448:     let
adamc@448:         fun po n ls =
adamc@448:             case ls of
adamc@448:                 [] => raise Fail "Unnest.positionOf"
adamc@448:               | x' :: ls' =>
adamc@448:                 if x' = x then
adamc@448:                     n
adamc@448:                 else
adamc@448:                     po (n + 1) ls'
adamc@448:     in
adamc@448:         po 0 ls
adamc@487:         handle Fail _ => raise Fail ("Unnest.positionOf("
adamc@448:                                      ^ Int.toString x
adamc@448:                                      ^ ", "
adamc@448:                                      ^ String.concatWith ";" (map Int.toString ls)
adamc@448:                                      ^ ")")
adamc@448:     end
adamc@448: 
adamc@448: fun squishCon cfv =
adamc@623:     U.Con.mapB {kind = fn _ => fn k => k,
adamc@448:                 con = fn cb => fn c =>
adamc@448:                                   case c of
adamc@448:                                       CRel n =>
adamc@448:                                       if n >= cb then
adamc@448:                                           CRel (positionOf (n - cb) cfv + cb)
adamc@448:                                       else
adamc@448:                                           c
adamc@448:                                     | _ => c,
adamc@448:                 bind = fn (cb, b) =>
adamc@448:                           case b of
adamc@623:                               U.Con.RelC _ => cb + 1
adamc@448:                             | _ => cb}
adamc@448:                0
adamc@448: 
adamc@448: fun squishExp (nr, cfv, efv) =
adamc@623:     U.Exp.mapB {kind = fn _ => fn k => k,
adamc@448:                 con = fn (cb, eb) => fn c =>
adamc@448:                                         case c of
adamc@448:                                             CRel n =>
adamc@448:                                             if n >= cb then
adamc@448:                                                 CRel (positionOf (n - cb) cfv + cb)
adamc@448:                                             else
adamc@448:                                                 c
adamc@448:                                           | _ => c,
adamc@448:                 exp = fn (cb, eb) => fn e =>
adamc@448:                                         case e of
adamc@448:                                             ERel n =>
adamc@448:                                             if n >= eb then
adamc@487:                                                 ERel (positionOf (n - eb) efv + eb - nr)
adamc@448:                                             else
adamc@448:                                                 e
adamc@448:                                           | _ => e,
adamc@448:                 bind = fn (ctx as (cb, eb), b) =>
adamc@448:                           case b of
adamc@448:                               U.Exp.RelC _ => (cb + 1, eb)
adamc@448:                             | U.Exp.RelE _ => (cb, eb + 1)
adamc@448:                             | _ => ctx}
adamc@448:                (0, nr)
adamc@448: 
adamc@448: type state = {
adamc@448:      maxName : int,
adamc@455:      decls : (string * int * con * exp) list
adamc@448: }
adamc@448: 
adamc@623: fun kind (_, k, st) = (k, st)
adamc@448: 
adamc@453: fun exp ((ks, ts), e as old, st : state) =
adamc@448:     case e of
adamc@825:         ELet (eds, e, t) =>
adamc@448:         let
adamc@487:             (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*)
adamc@453: 
adamc@487:             fun doSubst' (e, subs) = foldl (fn (p, e) => subExpInExp p e) e subs
adamc@448: 
adamc@487:             fun doSubst (e, subs, by) =
adamc@487:                 let
adamc@487:                     val e = doSubst' (e, subs)
adamc@487:                 in
adamc@487:                     liftExpInExp (~by) (length subs) e
adamc@487:                 end
adamc@487: 
adamc@487:             val (eds, (ts, maxName, ds, subs, by)) =
adamc@448:                 ListUtil.foldlMapConcat
adamc@487:                 (fn (ed, (ts, maxName, ds, subs, by)) =>
adamc@448:                     case #1 ed of
adamc@825:                         EDVal (p, t, e) =>
adamc@487:                         let
adamc@487:                             val e = doSubst (e, subs, by)
adamc@825: 
adamc@825:                             fun doVars ((p, _), ts) =
adamc@825:                                 case p of
adamc@825:                                     PWild => ts
adamc@825:                                   | PVar xt => xt :: ts
adamc@825:                                   | PPrim _ => ts
adamc@825:                                   | PCon (_, _, _, NONE) => ts
adamc@825:                                   | PCon (_, _, _, SOME p) => doVars (p, ts)
adamc@825:                                   | PRecord xpcs =>
adamc@825:                                     foldl (fn ((_, p, _), ts) => doVars (p, ts))
adamc@825:                                           ts xpcs
adamc@487:                         in
adamc@825:                             ([(EDVal (p, t, e), #2 ed)],
adamc@825:                              (doVars (p, ts),
adamc@487:                               maxName, ds,
adamc@487:                               ((0, (ERel 0, #2 ed))
adamc@487:                                :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs),
adamc@487:                               by))
adamc@487:                         end
adamc@448:                       | EDValRec vis =>
adamc@448:                         let
adamc@448:                             val loc = #2 ed
adamc@448: 
adamc@448:                             val nr = length vis
adamc@490:                             val subsLocal = List.filter (fn (_, (ERel _, _)) => false
adamc@490:                                                           | _ => true) subs
adamc@490:                             val subsLocal = map (fn (n, e) => (n + nr, liftExpInExp nr 0 e))
adamc@490:                                                 subsLocal
adamc@490: 
adamc@490:                             val vis = map (fn (x, t, e) =>
adamc@490:                                               (x, t, doSubst' (e, subsLocal))) vis
adamc@490: 
adamc@448:                             val (cfv, efv) = foldl (fn ((_, t, e), (cfv, efv)) =>
adamc@448:                                                        let
adamc@448:                                                            val (cfv', efv') = fvsExp nr e
adamc@448:                                                            (*val () = Print.prefaces "fvsExp"
adamc@448:                                                                     [("e", ElabPrint.p_exp E.empty e),
adamc@448:                                                                      ("cfv", Print.PD.string
adamc@448:                                                                                  (Int.toString (IS.numItems cfv'))),
adamc@448:                                                                      ("efv", Print.PD.string
adamc@448:                                                                                  (Int.toString (IS.numItems efv')))]*)
adamc@448:                                                            val cfv'' = fvsCon t
adamc@448:                                                        in
adamc@448:                                                            (IS.union (cfv, IS.union (cfv', cfv'')),
adamc@448:                                                             IS.union (efv, efv'))
adamc@448:                                                        end)
adamc@448:                                                    (IS.empty, IS.empty) vis
adamc@448: 
adamc@826:                             (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*)
adamc@826:                             (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*)
adamc@826:                             (*val () = app (fn (x, t) =>
adamc@453:                                              Print.prefaces "Var" [("x", Print.PD.string x),
adamc@826:                                                                    ("t", ElabPrint.p_con E.empty t)]) ts
adamc@826:                             val () = IS.app (fn n => print ("Free: " ^ Int.toString n ^ "\n")) efv*)
adamc@487: 
adamc@448:                             val cfv = IS.foldl (fn (x, cfv) =>
adamc@448:                                                    let
adamc@448:                                                        (*val () = print (Int.toString x ^ "\n")*)
adamc@448:                                                        val (_, t) = List.nth (ts, x)
adamc@448:                                                    in
adamc@448:                                                        IS.union (cfv, fvsCon t)
adamc@448:                                                    end)
adamc@448:                                                cfv efv
adamc@448:                             (*val () = print "B\n"*)
adamc@448: 
adamc@448:                             val (vis, maxName) =
adamc@448:                                 ListUtil.foldlMap (fn ((x, t, e), maxName) =>
adamc@448:                                                       ((x, maxName, t, e),
adamc@448:                                                        maxName + 1))
adamc@448:                                 maxName vis
adamc@448: 
adamc@487:                             val subs = map (fn (n, e) => (n + nr,
adamc@487:                                                           case e of
adamc@487:                                                               (ERel _, _) => e
adamc@487:                                                             | _ => liftExpInExp nr 0 e))
adamc@487:                                            subs
adamc@487: 
adamc@448:                             val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) =>
adamc@448:                                                           let
adamc@487:                                                               val e = (ENamed n, loc)
adamc@487: 
adamc@487:                                                               val e = IS.foldr (fn (x, e) =>
adamc@487:                                                                                    (ECApp (e, (CRel x, loc)), loc))
adamc@487:                                                                                e cfv
adamc@487: 
adamc@487:                                                               val e = IS.foldr (fn (x, e) =>
adamc@487:                                                                                    (EApp (e, (ERel (nr + x), loc)),
adamc@487:                                                                                     loc))
adamc@487:                                                                                e efv
adamc@448:                                                           in
adamc@487:                                                               (nr - i - 1, e)
adamc@448:                                                           end)
adamc@450:                                                       vis
adamc@450: 
adamc@448:                             val cfv = IS.listItems cfv
adamc@448:                             val efv = IS.listItems efv
adamc@448: 
adamc@487:                             val subs = subs' @ subs
adamc@448: 
adamc@448:                             val vis = map (fn (x, n, t, e) =>
adamc@448:                                               let
adamc@448:                                                   (*val () = Print.prefaces "preSubst"
adamc@448:                                                                           [("e", ElabPrint.p_exp E.empty e)]*)
adamc@490:                                                   val e = doSubst' (e, subs')
adamc@448: 
adamc@448:                                                   (*val () = Print.prefaces "squishCon"
adamc@448:                                                                           [("t", ElabPrint.p_con E.empty t)]*)
adamc@448:                                                   val t = squishCon cfv t
adamc@448:                                                   (*val () = Print.prefaces "squishExp"
adamc@448:                                                                           [("e", ElabPrint.p_exp E.empty e)]*)
adamc@487:                                                   val e = squishExp (nr, cfv, efv) e
adamc@448: 
adamc@487:                                                   (*val () = print ("Avail: " ^ Int.toString (length ts) ^ "\n")*)
adamc@453:                                                   val (e, t) = foldl (fn (ex, (e, t)) =>
adamc@448:                                                                          let
adamc@487:                                                                              (*val () = print (Int.toString ex ^ "\n")*)
adamc@448:                                                                              val (name, t') = List.nth (ts, ex)
adamc@448:                                                                          in
adamc@448:                                                                              ((EAbs (name,
adamc@448:                                                                                      t',
adamc@448:                                                                                      t,
adamc@448:                                                                                      e), loc),
adamc@448:                                                                               (TFun (t',
adamc@448:                                                                                      t), loc))
adamc@448:                                                                          end)
adamc@448:                                                                      (e, t) efv
adamc@487:                                                   (*val () = print "Done\n"*)
adamc@448: 
adamc@453:                                                   val (e, t) = foldl (fn (cx, (e, t)) =>
adamc@448:                                                                          let
adamc@448:                                                                              val (name, k) = List.nth (ks, cx)
adamc@448:                                                                          in
adamc@448:                                                                              ((ECAbs (Explicit,
adamc@448:                                                                                       name,
adamc@448:                                                                                       k,
adamc@448:                                                                                       e), loc),
adamc@448:                                                                               (TCFun (Explicit,
adamc@448:                                                                                       name,
adamc@448:                                                                                       k,
adamc@448:                                                                                       t), loc))
adamc@448:                                                                          end)
adamc@448:                                                                      (e, t) cfv
adamc@448:                                               in
adamc@487:                                                   (*Print.prefaces "Have a vi"
adamc@487:                                                                  [("x", Print.PD.string x),
adamc@487:                                                                   ("e", ElabPrint.p_exp ElabEnv.empty e)];*)
adamc@1017:                                                   ("$" ^ x, n, t, e)
adamc@448:                                               end)
adamc@448:                                           vis
adamc@448: 
adamc@487:                             val ts = List.revAppend (map (fn (x, _, t, _) => (x, t)) vis, ts)
adamc@448:                         in
adamc@487:                             ([], (ts, maxName, vis @ ds, subs, by + nr))
adamc@448:                         end)
adamc@487:                 (ts, #maxName st, #decls st, [], 0) eds
adamc@487: 
adamc@487:             val e' = doSubst (e, subs, by)
adamc@448:         in
adamc@487:             (*Print.prefaces "Before" [("e", ElabPrint.p_exp ElabEnv.empty e),
adamc@487:                                      ("se", ElabPrint.p_exp ElabEnv.empty (doSubst' (e, subs))),
adamc@487:                                      ("e'", ElabPrint.p_exp ElabEnv.empty e')];*)
adamc@825:             (ELet (eds, e', t),
adamc@448:              {maxName = maxName,
adamc@448:               decls = ds})
adamc@487:             (*(ELet (eds, doSubst (liftExpInExp (~(length subs - numRemaining)) (length subs) e) subs),*)
adamc@448:         end
adamc@448: 
adamc@448:       | _ => (e, st)
adamc@448: 
adamc@448: fun default (ctx, d, st) = (d, st)
adamc@448: 
adamc@448: fun bind ((ks, ts), b) =
adamc@448:     case b of
adamc@448:         U.Decl.RelC p => (p :: ks, map (fn (name, t) => (name, E.liftConInCon 0 t)) ts)
adamc@448:       | U.Decl.RelE p => (ks, p :: ts)
adamc@448:       | _ => (ks, ts)                        
adamc@448: 
adamc@448: val unnestDecl = U.Decl.foldMapB {kind = kind,
adamc@448:                                   con = default,
adamc@448:                                   exp = exp,
adamc@448:                                   sgn_item = default,
adamc@448:                                   sgn = default,
adamc@448:                                   str = default,
adamc@448:                                   decl = default,
adamc@448:                                   bind = bind}
adamc@448:                                  ([], [])
adamc@448: 
adamc@448: fun unnest file =
adamc@448:     let
adamc@448:         fun doDecl (all as (d, loc), st : state) =
adamc@448:             let
adamc@448:                 fun default () = ([all], st)
adamc@448:                 fun explore () =
adamc@448:                     let
adamc@448:                         val (d, st) = unnestDecl st all
adamc@455: 
adamc@455:                         val ds =
adamc@455:                             case #1 d of
adamc@455:                                 DValRec vis => [(DValRec (vis @ #decls st), #2 d)]
adamc@455:                               | _ => [(DValRec (#decls st), #2 d), d]
adamc@448:                     in
adamc@455:                         (ds,
adamc@448:                          {maxName = #maxName st,
adamc@448:                           decls = []})
adamc@448:                     end
adamc@448:             in
adamc@448:                 case d of
adamc@448:                     DCon _ => default ()
adamc@448:                   | DDatatype _ => default ()
adamc@448:                   | DDatatypeImp _ => default ()
adamc@448:                   | DVal _ => explore ()
adamc@448:                   | DValRec _ => explore ()
adamc@448:                   | DSgn _ => default ()
adamc@448:                   | DStr (x, n, sgn, str) =>
adamc@448:                     let
adamc@448:                         val (str, st) = doStr (str, st)
adamc@448:                     in
adamc@448:                         ([(DStr (x, n, sgn, str), loc)], st)
adamc@448:                     end
adamc@448:                   | DFfiStr _ => default ()
adamc@448:                   | DConstraint _ => default ()
adamc@448:                   | DExport _ => default ()
adamc@448:                   | DTable _ => default ()
adamc@448:                   | DSequence _ => default ()
adamc@754:                   | DView _ => default ()
adamc@448:                   | DClass _ => default ()
adamc@448:                   | DDatabase _ => default ()
adamc@459:                   | DCookie _ => default ()
adamc@718:                   | DStyle _ => default ()
adamc@448:             end
adamc@448: 
adamc@448:         and doStr (all as (str, loc), st) =
adamc@448:             let
adamc@448:                 fun default () = (all, st)
adamc@448:             in
adamc@448:                 case str of
adamc@448:                     StrConst ds =>
adamc@448:                     let
adamc@448:                         val (ds, st) = ListUtil.foldlMapConcat doDecl st ds
adamc@448:                     in
adamc@448:                         ((StrConst ds, loc), st)
adamc@448:                     end
adamc@448:                   | StrVar _ => default ()
adamc@448:                   | StrProj _ => default ()
adamc@448:                   | StrFun (x, n, dom, ran, str) =>
adamc@448:                     let
adamc@448:                         val (str, st) = doStr (str, st)
adamc@448:                     in
adamc@448:                         ((StrFun (x, n, dom, ran, str), loc), st)
adamc@448:                     end
adamc@448:                   | StrApp _ => default ()
adamc@448:                   | StrError => raise Fail "Unnest: StrError"
adamc@448:             end
adamc@448: 
adamc@448:         val (ds, _) = ListUtil.foldlMapConcat doDecl
adamc@448:                       {maxName = U.File.maxName file + 1,
adamc@448:                        decls = []} file
adamc@448:     in
adamc@448:         ds
adamc@448:     end
adamc@448: 
adamc@448: end