Source

love studio / LoveStudio / LuaAnalyzer / ProjectChecker.fs

Full commit
module LuaAnalyzer.ProjectChecker

open System.Diagnostics.Contracts

open Type
open TypedSyntax
open ErrorList
open Context
open TypeCollector
open SubtypeGraphBuilder
open TypeChecker

type GenList<'T> = System.Collections.Generic.List<'T>

let extTyCache = ref (new Map<string, int64*Option<Type*Type>>([]))

/// env - A partially-constructed type environment which contains a complete subtype
/// graph, but nothing else.
///
/// collectorMap - maps each type-collected module name to the type collector which
/// collects it.
///
/// astMap - Maps each module to a typed ast for that module's code
///
/// Iterates through each module mentioned in the subtype graph contained in tenv,
/// collecting an instance and a constructor type from each one, accumulating these
/// types into the consMap and typeMap fields of the environment.
let buildExternalTypes (tenv : TypeEnvironment)
                       (collectorMap : Map<string,TypeCollector>)
                       (astMap : Map<string,TypedStatement>)
                       : TypeEnvironment =

    //In tenv, all built-in, API, and project-defined types have
    //been recorded in instanceTypes, but actual types for the project-defined
    //ones have not been entered into typeMap
    Contract.Requires(tenv.typeMap.Count <= tenv.instanceTypes.Count) 
    
    // In the result, all project-defined instance types have been entered
    // into the typeMap. Constructor types have potentially been added
    // to the typeMap as well, so strict equality is not guaranteed.
    Contract.Ensures(Contract.Result<TypeEnvironment>().typeMap.Count >= Contract.Result<TypeEnvironment>().instanceTypes.Count)
    
    let foldType (tenv : TypeEnvironment) (typeName : string) : TypeEnvironment =
        if tenv.instanceTypes.Contains typeName then
            let fileName = tenv.typeFiles.Item typeName
            let ast = astMap.Item typeName
            let collector = collectorMap.Item typeName

            match collector.externalTypeBuilder tenv typeName fileName ast with
            | Some (exTy, consTy) ->
                {
                    tenv with
                        typeMap = tenv.typeMap.Add(typeName,exTy)
                        consMap = tenv.consMap.Add(typeName,consTy)
                }
            | None ->
                {
                    tenv with
                        typeMap = tenv.typeMap.Add(typeName,UnknownTy)
                        consMap = tenv.consMap.Add(typeName,UnknownTy)
                }
        else
            tenv
       
    List.fold foldType tenv tenv.TopSortedTypeNames

/// ctxt - The initial context, which we add global bindings to
/// modules - a sequence of, for all modules in the project, 
///   (fullPath,moduleName,contents,lastModifiedTime) quadruples
/// globalsModName - the name of the globals module
///
/// If a module with the name globalsModName exists, we extract the
/// name/field pairs of all globals which are assigned in this module,
/// adding them to ctxt, replacing any existing entries with identical names.
/// Returns the resulting context.
let buildGlobalCtxt (ctxt : Context) (modules : seq<string*string*TypedStatement*int64>) (globalsModName : string) =
    
    Contract.Ensures(Contract.Result<Context>().tenv.typeMap.Count = ctxt.tenv.typeMap.Count)
    Contract.Ensures(Contract.Result<Context>().venv.Count >= ctxt.venv.Count)

    let globalsModule = Seq.tryFind (fun (fileName,modName,_,_) -> modName = globalsModName) modules
    
    match globalsModule with
    | Some(fileName,_,ast,_) ->
        currentFileName := fileName
        let userGlobals = getAssigns ctxt ast
        {
        ctxt with
            venv = cover ctxt.venv userGlobals
        }
    | _ ->
        ctxt

/// ctxt - The initial context, which we add internal types to.
/// collectorMap - maps each external type name to the name of the collector which 
///                collected its type.
/// astMap - Maps each module to a typed abstract syntax tree of that module's code
///
/// Given a context for which external types have been collected, visits all modules
/// which have been determined to define types, collecting their internal types and
/// adding them to the context.
///
/// Internal type collection topologically sorts the subtype graph, and visits 
/// modules in this order. This is necessary, because class constructors, which define
/// internal types, may reference the internal types of parent class in their bodies.
let buildInternalTypes (ctxt : Context) 
                       (collectorMap : Map<string,TypeCollector>) 
                       (astMap : Map<string,TypedStatement>) 
                       : Context  =
    
    Contract.Ensures (Contract.Result<Context>().tenv.typeMap.Count >= ctxt.tenv.typeMap.Count)

    let topSortedTypeNames = ctxt.tenv.TopSortedTypeNames
    
    let foldModule (ctxt : Context) (modName : string) : Context =
        let tenv = ctxt.tenv
        let fileName = tenv.typeFiles.Item modName

        if tenv.instanceTypes.Contains modName then
            let fileName = tenv.typeFiles.Item modName
            let ast = astMap.Item modName
            let collector = collectorMap.Item modName
            let collectedTypeMap = collector.internalTypeBuilder ctxt modName fileName ast

            let tenv = 
                {
                tenv with
                    typeMap = (cover tenv.typeMap collectedTypeMap)
                }

            {
            ctxt with
                tenv = tenv
            }
        else
            ctxt
    
    List.fold foldModule ctxt topSortedTypeNames

/// Sets currentFileName to fileName and then type checks ast w.r.t. baseCtxt
let typeCheck (baseCtxt : Context) (fileName : string) (ast : TypedStatement) =
    currentFileName := fileName
    typeCheckStat baseCtxt ast

/// collectorMap - maps each type-collected module name to the type collector
///                which collected it.
/// preGlobalsCtxt - A context with a complete type environment and a value environment
///                  that contains external API definition values, but no globals.
///
/// ctxt - A context with a complete type environment and a value environment that
///        contains API definitions AND globals.
///
/// modules - a list containing, for each module in the project, a 
///          (fullPathName,moduleName,typedSyntaxTree,lastModifiedTime) quadruple.
///
/// Typechecks each file in the modules list, adding all encountered typing errors
/// to the error list. Depending on the nature of the files, they will be conditioned
/// for typechecking differently. 
///
/// - Files which define types are first decorated and checked
/// for miscellaneous errors. Then, they are checked w.r.t. ctxt.
///
/// - The module called "globals" is checked w.r.t. preGlobalsCtxt, with the
///   addGlobals flag set to true.
///
/// - All non-type-defining, non-globals files are checked wr.t. ctxt.
let runTypeChecker (collectorMap : Map<string,TypeCollector>) 
                   (preGlobalsCtxt : Context)
                   (ctxt : Context) 
                   (modules : seq<string*string*TypedStatement*int64>) =
    
    Contract.Requires(preGlobalsCtxt.venv.Count <= ctxt.venv.Count)

    for fileName, moduleName, ast, lastMod in modules do
        if ctxt.tenv.instanceTypes.Contains moduleName then
            let collector = collectorMap.Item moduleName
            let decoratedAST = collector.decorate ctxt moduleName ast
            collector.detectMiscErrors ctxt moduleName fileName decoratedAST
            typeCheck ctxt.TrackErrors fileName decoratedAST
        else
            if moduleName = "globals" then
                typeCheck preGlobalsCtxt.AddGlobals.TrackErrors fileName ast
            else 
                typeCheck ctxt.TrackErrors fileName ast

/// Maps a filename to the typed ast that resulted the last time that 
/// file's contents were parsed and typed, paired with the last-modified time
/// for the contents.
let astCache = ref (new Map<string, int64*TypedStatement>([]))

/// Gets an ast for the given module. If 
let getAST ((fileName,modName,modContents,lastMod) : string*string*string*int64) =
    let ast =
        if (!astCache).ContainsKey fileName then
            let stamp,cachedAST = (!astCache).Item fileName
 
            if lastMod > stamp then
                let parsed,_ = HandParser.parse modContents
                let ast = typeStatement parsed
                astCache := astCache.contents.Add(fileName, (lastMod,ast))
                ast
            else
                cachedAST
        else
            let parsed,_ = HandParser.parse modContents
            let ast = typeStatement parsed
            astCache := astCache.contents.Add(fileName, (lastMod,ast))
            ast
    
    
    (fileName,modName,ast,lastMod), (modName,ast) 

/// modules - a sequence of all modules in the project
///
/// targetFile - None signifies that the entire project should be typechecked. 
/// Otherwise, we only check the specified file (but still collect from the entire project)
///
/// queryPos - If targetFile is used, we may be checking it so that information about some
/// word in the program can be retrieved. If so, the some position in the word is used as this argument.
///
/// Runs the typechecker--either for generating type checking errors or querying information
/// about the program. Note that this function performs everything needed for typechecking, 
/// including type collection.
let runTypeCollectors (modules : seq<LuaModule>) (targetFile : Option<string>) (queryPos : Option<int>) : Option<TypeEnvironment> =

    Contract.Requires(targetFile.IsSome || (not queryPos.IsSome))

    let mapped = (Seq.map getAST modules)
    let modules = Seq.map fst mapped
    let astMap = Map.ofSeq (Seq.map snd mapped)
    
    try 
        let tenv0 = getBaseContext().tenv
        let allTypeNames0 = getBaseContext().tenv.instanceTypes

        let tenv, collectorMap = buildSubtypeGraph modules tenv0 allTypeNames0
        let tenv = buildExternalTypes tenv collectorMap astMap
        
        let preGlobalsCtxt = 
            {
            !baseContext with
                tenv = tenv
            }

        let ctxt = buildGlobalCtxt preGlobalsCtxt modules "globals"
        let ctxt = buildInternalTypes ctxt collectorMap astMap
        ctxt.tenv.CheckStructuralSubtyping()
        
        let modules = 
            if targetFile.IsSome then
                match (Seq.tryFind (fun (fileName,_,_,_) -> fileName = targetFile.Value) modules) with
                | Some(targetModule) ->
                    Seq.ofList [targetModule]
                | _ ->
                    modules
            else
                modules
        
        let ctxt = { ctxt with queryPos = queryPos }
        runTypeChecker collectorMap preGlobalsCtxt ctxt modules

        Some tenv
    with
    | BrokenEdgeException(child,parent,file,rng) ->
        addError 
            file
            ( child + " inherits from non-existant or non-instance type " + parent )
            rng
        None
    | TypeGraphDiamondException(source,dest,pathA,pathB,file,rng) ->
        addError
            file 
            ("diamond in subtype graph from " + source + " to " + dest + "\n" + pathA.ToString() + "\n" + pathB.ToString())
            rng
        None
    | TypeGraphCycleException(cycle,file,rng) ->
        addError
            file
            ("cycle in subtype graph: " + cycle.ToString())
            rng
        None
    | CollectionConflict(collectorName1, collectorName2, moduleName,file,rng) ->
        addError
            file
            ("two different type collection plugins, " + collectorName1 + " and " + collectorName2 + ", collected a type from " + moduleName + ".")
            rng
        None
    | StructuralSubtypingError(msg,file,rng) ->
        addError
            file
            msg
            rng
        None
    | Failure(msg) ->
        System.Console.WriteLine("collection error: " + msg)
        failwith msg

/// modules - sequence of all lua modules in the project
/// typeCheck - whether or not to generate type errors
///
/// Generates a list of errors in the project. If typeCheck is true, it generates syntax
/// errors and type errors. If typeCheck is false, it generates syntax errors only.
let typeCheckProject (modules : seq<LuaModule>) (typeCheck : bool) : GenList<string*string*Range> =
    errors.Clear()
    let env =
        if typeCheck then
            runTypeCollectors modules None None
        else
            Seq.iter (getAST >> ignore) modules
            None

    errors

/// modules - a sequence of all modules in the project
/// targetFile - the full path name of the file to query from
/// queryPos - the position (char index) in the target file which we are querying
///
/// Retrieves a description (and definition location) of the program element containing 
/// the specified position in the specified file. This description is generated from the 
/// element's type and/or field when possible.
///
/// Returns a (identifier description, definition location, type description) triple.
/// When any of the aforementioned items cannot be obtained, it returns "",NoLocation, and ""
/// respectively.  
let queryDescAndLoc (modules : seq<LuaModule>) (targetFile : string) (queryPos : int) =
    refStubDesc := ""
    refStubDefLoc := NoLocation
    refStubTy := UnknownTy
    ignore (runTypeCollectors modules (Some(targetFile)) (Some(queryPos)))

    !refStubDesc,!refStubDefLoc,(!refStubTy).ToStringElaborate()

/// modules - a sequence of all lua modules in the project
/// targetFile - the full path of the lua file containing the context 
/// stub (a call to lucbdnioua) to extract from.
///
/// Given a project and a file within that project, typechecks the specified
/// file, recording the context when the typechecker reaches a call to "lucbdnioua",
/// It is assumed that exactly one call to lucbdnioua exists in the file.
let getStubContextInProject (modules : seq<LuaModule>) (targetFile : string) =
    ignore (runTypeCollectors modules (Some(targetFile)) None)
    !refStubContext

/// ctxt - a context to typecheck ast with
/// ast - a syntax tree with an embedded placeholder to extract the context at
///
/// Typechecks the supplied statement w.r.t. the supplied context, recording
/// the context when the typechecker reaches a call to "lucbdnioua". It is assumed
/// that exactly one such call exists in the statement.
let getStubContext (ctxt : Context) (ast : TypedStatement) =
    ignore (typeCheckStat ctxt ast)
    !refStubContext