love studio / LoveStudio / LuaAnalyzer / SubtypeGraphBuilder.fs

Full commit
module LuaAnalyzer.SubtypeGraphBuilder

open System.Diagnostics.Contracts

open Type
open TypedSyntax
open TypeCollector
open Plugins

/// The data we need to track during the construction of the
/// subtype graph.
type TypeGraphBuilderState = {

    /// the type environment containing the graph we are building
    tenv : TypeEnvironment
    /// all type names collected so far
    allTypeNames : Set<string>

    //TODO: perhaps this should be included in type environment
    //except that would have to map module names to type collector names
    /// maps module names to the collectors which collected them
    collectedFrom : Map<string,TypeCollector>

type TopSortColor =
    /// gray nodes are currently being processed
    | GRAY
    /// black nodes have already been processed
    | BLACK

/// BrokenEdgeException(child,parent,fileName,rng) 
/// Thrown when a class inherits from a class which was not collected
exception BrokenEdgeException of string*string*string*Range

exception TypeGraphCycleException of List<string>*string*Range

/// TypeGraphDiamondException(source, dest, pathA, pathB,fileName,rng)
/// thrown when the type named source can reach the type named dest
/// via two different paths: pathA and pathB
exception TypeGraphDiamondException of string*string*List<string>*List<string>*string*Range

/// CollectionConflict(collectorName1,collectorName2,moduleName,fileName,range)
/// thrown when two different collectors both successfully collect
/// types from a module.
exception CollectionConflict of string*string*string*string*Range

/// Used for errors in the implementations of type collectors.
exception CollectorError of string

let lastModCache = ref (new Map<string,int64>([]))

let typeGraphBuilderCache = ref (new Map<string, int64*Option<Range*List<string*Range>*List<string*string>>>([]))

/// If any edge leads to an edge which is not an instance type (or doesn't exist),
/// raise an exception
let checkBrokenEdges (tenv : TypeEnvironment) =
    for kv in tenv.edges do
        let srcName = kv.Key
        let edges = kv.Value         

        for edge in edges do
            if not ( tenv.instanceTypes.Contains edge ) then
                let file = tenv.typeFiles.Item srcName
                let rng = tenv.typeDeclarationRanges.Item srcName
                raise( BrokenEdgeException(srcName,edge,file,rng) )

/// If the supplied module is collected by collector, accumulate its type graph data into acc
let foldModule (collector : TypeCollector) (acc : TypeGraphBuilderState) ((fileName,moduleName,ast,lastMod) : string*string*TypedStatement*int64) =

    let tenv = acc.tenv
    let collectedFrom = acc.collectedFrom

    let result =
        if (!typeGraphBuilderCache).ContainsKey fileName then
            let timeStamp, res = (!typeGraphBuilderCache).Item fileName
            if lastMod > timeStamp then
                let res = collector.typeGraphBuilder moduleName fileName ast
                typeGraphBuilderCache := (!typeGraphBuilderCache).Add(fileName, (lastMod,res))
            let res = collector.typeGraphBuilder moduleName fileName ast
            typeGraphBuilderCache := (!typeGraphBuilderCache).Add(fileName, (lastMod,res))

    match collector.typeGraphBuilder moduleName fileName ast with
    | Some (extRng,internalTypeNames,edges) ->
        if collectedFrom.ContainsKey moduleName then
            let file = tenv.typeFiles.Item moduleName
            let rng = tenv.typeDeclarationRanges.Item moduleName
                    (collectedFrom.Item moduleName).name, 
            let tenv =
                tenv with
                    instanceTypes = tenv.instanceTypes.Add(moduleName)
                    typeFiles = tenv.typeFiles.Add(moduleName,fileName)
                    edges = tenv.edges.Add(moduleName,[])
                    typeDeclarationRanges = tenv.typeDeclarationRanges.Add(moduleName,extRng)
            let acc =
                acc with
                    tenv = tenv
                    collectedFrom = acc.collectedFrom.Add(moduleName,collector)
                    allTypeNames = acc.allTypeNames.Add(moduleName)

            let foldInternalTypeName (acc : TypeGraphBuilderState) (typeName,rng) =
                let tenv =
                    acc.tenv with
                        typeFiles = acc.tenv.typeFiles.Add(typeName,fileName)
                        typeDeclarationRanges = acc.tenv.typeDeclarationRanges.Add(typeName,rng)
                        edges = acc.tenv.edges.Add(typeName,[])

                acc with
                    tenv = tenv
                    allTypeNames = acc.allTypeNames.Add(typeName)
                    collectedFrom = acc.collectedFrom.Add(typeName,collector)

            let acc = List.fold foldInternalTypeName acc internalTypeNames

            let foldEdge (acc : TypeGraphBuilderState) ((t0,t1) : string*string) =
                let tenv =
                    acc.tenv with
                        edges = acc.tenv.edges.Add(t0,t1 :: (acc.tenv.edges.Item t0))

                { acc with tenv = tenv }

            let acc = List.fold foldEdge acc edges

    | None ->

/// If the root's type collector requires a tree ancestor graph, we raise an 
/// exception if there are cycles or diamonds in its the ancestor graph.
/// Otherwise, we raise an exception if there are cycles in its ancestor graph.
let checkStructureErrors (tenv : TypeEnvironment) (collectedFrom : Map<string,TypeCollector>) (root : string) : unit =
    let parent : Ref< Map<string,string> > = ref Map.empty
    let color : Ref< Map<string,TopSortColor> > = ref Map.empty

    let typeGraphIsTree = 
        if collectedFrom.ContainsKey root then
            (collectedFrom.Item root).typeGraphIsTree

    let rec traceParents (src : string) (dst : string) =
        if src = dst then
            src :: (traceParents ((!parent).Item src) dst) 

    let rec checkStructureErrorsAux (node : string) =
        color := (!color).Add(node, TopSortColor.GRAY)

        let children = 
            match tenv.edges.ContainsKey node with
            | true ->
                tenv.edges.Item node
            | false ->

        for adj in children do
            match (!color).TryFind adj with
            | Some(TopSortColor.GRAY) ->
                let file = tenv.typeFiles.Item adj
                let rng = tenv.typeDeclarationRanges.Item adj
                raise( TypeGraphCycleException(adj :: (traceParents node adj),file,rng) )
            | Some(TopSortColor.BLACK) ->
                if typeGraphIsTree then
                    let file = tenv.typeFiles.Item adj
                    let rng = tenv.typeDeclarationRanges.Item adj
                            (traceParents adj root),
                            adj :: (traceParents node root),
                    color := (!color).Add(adj, TopSortColor.GRAY)
                    parent := (!parent).Add(adj,node)
                    checkStructureErrorsAux adj      
            | None ->
                parent := (!parent).Add(adj,node)
                checkStructureErrorsAux adj

        color := (!color).Add(node,TopSortColor.BLACK) 

    checkStructureErrorsAux root

/// Raise an exception if there are any broken edges or cycles in the subtype graph.
/// If some type collector requires ancestor graphs to be trees, we raise an exception
/// if diamonds are found in the subtype graph.
let checkGraphErrors (state : TypeGraphBuilderState) =
    checkBrokenEdges state.tenv

    // check for errors in subtype graph
    for typeName in state.allTypeNames do
        checkStructureErrors state.tenv state.collectedFrom typeName

/// modules - a sequence of (filename,modulename,ast,timestamp) quadruples
/// for all modules in the project
/// tyenv0 - The type environment after having read in all API data from XML files
/// typeNames0 - The names of all types read from API definitions in XML files
/// Starting with the subtypegraph in tenv0, accumulates a subject graph computed
/// from the lua project whose modules are all included in the modules sequence.
/// Returns the resulting type environment, along with a map which record which
/// modules were collected by which type collectors.
let buildSubtypeGraph (modules : seq<string*string*TypedStatement*int64>) 
                      (tenv0 : TypeEnvironment) 
                      (typeNames0 : Set<string>)
                      : TypeEnvironment*Map<string,TypeCollector> =
    let foldCollector (acc : TypeGraphBuilderState) (collector : TypeCollector) =
        Seq.fold (foldModule collector) acc modules

    let initialState = 
            tenv = tenv0
            allTypeNames = typeNames0
            collectedFrom = Map.empty
    let result = List.fold foldCollector initialState (!typeCollectors) 
    checkGraphErrors result