(*
 * Get the set of reachable SNODEs in a given dependency graph.
 *
 * (C) 1999 Lucent Technologies, Bell Laboratories
 *
 * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
 *)
signature REACHABLE = sig
    (* These two functions simply give you the set of (non-stable)
     * modules reachable from some root and the fringe of stable
     * modules that surrounds the non-stable portion. *)
    val reachable' :
	DependencyGraph.sbnode list -> SmlInfoSet.set * StableSet.set
    val reachable : GroupGraph.group -> SmlInfoSet.set * StableSet.set

    (* "snodeMap" gives us handles at arbitrary points within the (non-stable)
     * portion of a dependency graph.
     * This is used by "slave" mode compiler. *)
    val snodeMap : GroupGraph.group -> DependencyGraph.snode SrcPathMap.map

    (* Given a library (or group) g, "groupsOf g" gets the set of
     * subgroups (but not sub-libraries) of that group.  The result
     * will include the argument itself. *)
    val groupsOf : GroupGraph.group -> SrcPathSet.set

    (* Given an arbitrary group graph rooted at group g, "stableLibsOf g"
     * gets the set of stable libraries reachable from g. *)
    val stableLibsOf : GroupGraph.group -> GroupGraph.group SrcPathMap.map

    (* Given a "closed" subset of (non-stable) nodes in a dependency graph,
     * "frontier" gives you the set of frontier nodes of that set.  The
     * closed set is given by its indicator function (first argument).
     * ("closed" means that if a node's ancestors are all in
     * the set, then so is the node itself.  A frontier node is a node that
     * is in the set but either not all of its ancestors are or the node
     * is an export node.) *)
    val frontier : (BinInfo.info -> bool) -> GroupGraph.group -> StableSet.set
end

structure Reachable :> REACHABLE = struct
    structure DG = DependencyGraph
    structure GG = GroupGraph

    local
	fun reach ops (export_nodes: DG.sbnode list) = let
	    val { add, member, empty } = ops
	    fun snode (x as DG.SNODE n, (known, stabfringe)) = let
		val { smlinfo = i, localimports = l, globalimports = g } = n
	    in
		if member (known, i) then (known, stabfringe)
		else foldl farsbnode
		           (foldl snode (add (known, i, x), stabfringe) l)
			   g
	    end
	
	    and farsbnode ((_, n), ksf) = sbnode (n, ksf)
		
	    and sbnode (DG.SB_BNODE (DG.BNODE n, _, _), (known, stabfringe)) =
		(known, StableSet.add (stabfringe, #bininfo n))
	      | sbnode (DG.SB_SNODE n, ksf) = snode (n, ksf)
	in
	    foldl sbnode (empty, StableSet.empty) export_nodes
	end

	fun force f = f ()

	fun snodeMap' (exports: DG.impexp SymbolMap.map, acc) = let
	    fun add (m, i, x) = SrcPathMap.insert (m, SmlInfo.sourcepath i, x)
	    fun member (m, i) = SrcPathMap.inDomain (m, SmlInfo.sourcepath i)
	in
	    #1 (reach { add = add, member = member, empty = acc }
		      (map (#2 o force o #1) (SymbolMap.listItems exports)))
	end
    in
	val reachable' =
	    reach { add = fn (s, i, _) => SmlInfoSet.add (s, i),
		    member = SmlInfoSet.member,
		    empty = SmlInfoSet.empty }

	fun reachable (GG.GROUP { exports, ... }) =
	              reachable' (map (#2 o force o #1)
				      (SymbolMap.listItems exports))
	  | reachable GG.ERRORGROUP = (SmlInfoSet.empty, StableSet.empty)

	fun snodeMap g = let
	    fun snm (GG.ERRORGROUP, x) = x
	      | snm (g as GG.GROUP grec, (a, seen)) = let
		    val { exports, sublibs, grouppath, ... } = grec
		in
		    if SrcPathSet.member (seen, grouppath) then (a, seen)
		    else foldl (fn ((_, g, _), x) => snm (g (), x))
		               (snodeMap' (exports, a),
				SrcPathSet.add (seen, grouppath))
			       sublibs
		end
	in
	    #1 (snm (g, (SrcPathMap.empty, SrcPathSet.empty)))
	end

	fun groupsOf g = let
	    fun subgroups (GG.GROUP { kind = GG.NOLIB x, ... }) = #subgroups x
	      | subgroups (GG.GROUP { kind = GG.LIB { kind = GG.DEVELOPED x,
						      ... },
				      ... }) = #subgroups x
	      | subgroups _ = []
	    fun go (GG.ERRORGROUP, a) = a
	      | go (g as GG.GROUP { grouppath, ... }, a) = let
		    val sgl = subgroups g
		    fun sl ((p, gth, _), a) =
			case gth () of
			    g as GG.GROUP { kind = GG.NOLIB _, ... } =>
			    if SrcPathSet.member (a, p) then a else go (g, a)
			  | _ => a
		in
		    SrcPathSet.add (foldl sl a sgl, grouppath)
		end
	in
	    go (g, SrcPathSet.empty)
	end

	fun stableLibsOf GG.ERRORGROUP = SrcPathMap.empty
	  | stableLibsOf (g as GG.GROUP { grouppath, ... }) = let
		fun slo' ((_, GG.ERRORGROUP), x) = x
		  | slo' ((p, g as GG.GROUP grec), (seen, res)) = let
			val { kind, sublibs, ... } = grec
		    in
			if SrcPathSet.member (seen, p) then (seen, res)
			else
			    let
				val (seen, res) = foldl slo (seen, res) sublibs
				val seen = SrcPathSet.add (seen, p)
			    in
				case kind of
				    GG.LIB { kind = GG.STABLE _, ... } =>
				    (seen, SrcPathMap.insert (res, p, g))
				  | _ => (seen, res)
			    end
		    end
		and slo ((p, gth, _), x) = slo' ((p, gth ()), x)
	    in
		#2 (slo' ((grouppath, g),
			  (SrcPathSet.empty, SrcPathMap.empty)))
	    end

	fun frontier _ GG.ERRORGROUP = StableSet.empty
	  | frontier inSet (GG.GROUP { exports, ... }) = let
	    fun bnode (DG.BNODE n, (seen, f)) = let
		val i = #bininfo n
		val li = #localimports n
	    in
		if StableSet.member (seen, i) then (seen, f)
		else let
		    val seen = StableSet.add (seen, i)
		in
		    if inSet i then (seen, StableSet.add (f, i))
		    else foldl bnode (seen, f) li
		end
	    end
	    fun get_bn ((nth, _, _), bnl) =
		case nth () of
		    (_, DG.SB_BNODE (n, _, _)) => n :: bnl
		  | _ => bnl
	    val bnl = SymbolMap.foldl get_bn [] exports
	in
	    #2 (foldl bnode (StableSet.empty, StableSet.empty) bnl)
	end
    end
end