Source

love studio / LoveStudio / LuaAnalyzer / LuaAnalyzer.fs

Full commit
module LuaAnalyzer.Analyzer

open Utils
open Type
open TypedSyntax
open TypeChecker
open Syntax
open TypeCollector
open ProjectChecker

open System.ComponentModel.Composition
open System.ComponentModel.Composition.Hosting

let appDataDir = System.Environment.SpecialFolder.ApplicationData
let pluginsDir = System.Environment.GetFolderPath(appDataDir) + "\\LoveStudio"

type ITypeCollectorPlugin =
    /// Activates the type collector
    abstract member Init : unit -> unit

    /// Returns a sequence of all relative paths of lua library
    /// files to copy from the plugin directory to the project 
    /// directory
    abstract member GetLibPaths : unit -> seq<string>

/// The standard .NET generic list class. (A resizable array.)
type GenList<'T> = System.Collections.Generic.List<'T>

type public Error = string*LuaAnalyzer.Syntax.Range

let private ref_listStatErrors : Ref<Statement -> List<Error>> = 
    ref (fun x -> [])

let private listStatErrors (stat : Statement) =
    !ref_listStatErrors stat

let private ref_listExprErrors : Ref<Expr -> List<Error>> =
    ref (fun x -> [])
    
let private listExprErrors (expr : Expr) =
    !ref_listExprErrors expr

let rec private listFieldErrors (field : ConstructorField) : List<Error> =
    match field with
    | ListField(_,e,_) ->
        listExprErrors e
    | RecField(_,e0,e1,_) ->
        List.append (listExprErrors e0) (listExprErrors e1)

ref_listExprErrors := fun exp ->
    match exp with
    | ErrorExpr(msg,rng) ->
        [(msg,rng)]
    | Expr(exprs, stats, fields) ->
        let exprErrors = List.concat (List.map listExprErrors exprs)
        let statErrors = List.concat (List.map listStatErrors stats)
        let fieldErrors = List.concat (List.map listFieldErrors fields)
        List.concat [exprErrors;statErrors;fieldErrors]

ref_listStatErrors := fun ast ->
    match ast with
    | ErrorStatement(str,rng) ->
        [(str,rng)]
    | Statement(exprs,stats) ->
        let exprErrors = List.concat (List.map listExprErrors exprs)
        let statErrors = List.concat (List.map listStatErrors stats)
        List.append exprErrors statErrors

let listErrors (ast : Statement) =
    
    let errors = listStatErrors ast
    let ret = new System.Collections.Generic.List<Error>()
    for i = 0 to errors.Length-1 do
        ignore( ret.Add(errors.[i]) )
    ret

let private ref_getExprError : Ref<int -> Expr -> Option<string>> = 
    ref (fun x y -> None)

let private getExprError (pos : int) (expr : Expr) : Option<string> =
    !ref_getExprError pos expr

let private ref_getStatError : Ref<int -> Statement -> Option<string>> = 
    ref (fun x y -> None)

let private getStatError (pos : int) (stat : Statement) : Option<string> =
    !ref_getStatError pos stat 

let private ref_getError 
    : Ref<int -> List<Expr> -> List<Statement> -> List<ConstructorField> -> Option<string>> =
    
    ref (fun w x y z -> None)

let private getError (pos : int)
                     (exprs : List<Expr>)
                     (stats : List<Statement>)
                     (fields : List<ConstructorField>) =

    !ref_getError pos exprs stats fields

let rec private getFieldError (pos : int) (field : ConstructorField) =
    match field with
    | ErrorField(msg,rng) when inRange pos rng ->
        Some msg
    | ConstructorField(exprs,stats,fields) ->
        getError pos exprs stats fields      
    
ref_getStatError := fun (pos : int) (stat : Statement) ->
    match stat with
    | ErrorStatement(msg,rng) when inRange pos rng ->
        Some msg
    | Statement(exprs,stats) ->
        getError pos exprs stats []

ref_getExprError := fun (pos : int) (expr : Expr) ->
    match expr with
    | ErrorExpr(msg,rng) when inRange pos rng ->
        Some msg
    | Expr(exprs,stats,fields) ->
        getError pos exprs stats fields

ref_getError := fun (pos : int) 
                    (exprs : List<Expr>) 
                    (stats : List<Statement>) 
                    (fields : List<ConstructorField>) ->
             
    let opStatErrors = List.map (getStatError pos) stats
    let opExprErrors = List.map (getExprError pos) exprs
    let opFieldErrors = List.map (getFieldError pos) fields

    let statErr = List.tryFind (fun x -> Option.isSome x) opStatErrors
    let exprErr = List.tryFind (fun x -> Option.isSome x) opExprErrors
    let fieldErr = List.tryFind (fun x -> Option.isSome x) opFieldErrors

    match (statErr,exprErr) with
    | (Some(Some x), None)
    | (None, Some(Some x)) ->
        Some x
    | (None, None) ->
        None
    | _ ->
        failwith "wtf" 

let getErrorFromPos (pos : int) (stat : Statement) =
    match getStatError pos stat with
    | Some x ->
        x
    | None ->
        null

let hasErrors (stat : Statement) =
    (listStatErrors stat).Length = 0

/// C# compatible forms for types
type CSRecordType = {
    name : string
    desc : string
    fields : GenList<string*string*string>
    methods : GenList<string*string*string>
}

type CSFunctionType = {
    desc : string
    formals : GenList<string*string*string>
    rets : GenList<string*string>
    isMethod : bool
    defLocation : DefinitionLocation
}

let makeCSFunction (fieldDesc : string) (ty : Type) =
    match ty with
    | CallableTy(tyDesc,_ :: formals,rets,true, defLocation)
    | CallableTy(tyDesc,formals,rets,false,defLocation) ->
        let formalsList = new GenList<string*string*string>()
        for (name,desc,ty) in formals do
            formalsList.Add(name,desc,ty.ToString())

        let retList = new GenList<string*string>()
        for (desc,ty) in rets do
            retList.Add(desc,ty.ToString())
        
        {
            desc = if not (tyDesc = "") then tyDesc else fieldDesc
            formals = formalsList
            rets = retList
            isMethod = false
            defLocation = defLocation
        }
    | _ ->
        failwith "API definition error: overloads should only contain callable types"

let getFieldOrMethodInfo (modules : seq<string*string*string*int64>) (lexp : Expr) (fieldOrMethodName : string) (targetFileName : string) =
    let stubCtxt = getStubContextInProject modules targetFileName
    let typed = typeExpr lexp
    let ctxt = stubCtxt.DontTrackErrors.IsNotLeftExpr
    match Type.Coerce ctxt.tenv (fst (typeCheckExpr ctxt typed)) with
    | RecordTy(name,desc,_,_,fields,methods,loc) ->
        let isMethod, (fieldDesc, fieldTy, loc) = 
            if fields.ContainsKey fieldOrMethodName then
                let field = fields.Item fieldOrMethodName
                false, (field.desc,field.ty,field.loc)
            else if methods.ContainsKey fieldOrMethodName then
                let {desc=desc;ty=ty;isAbstract=_;loc=loc} = methods.Item fieldOrMethodName
                true, (desc,ty,loc)
            else
                false, ("", UnknownTy, NoLocation)

        match fieldTy with
        | FunctionTy(_,_,_,_,_) ->
            new GenList<CSFunctionType>([makeCSFunction fieldDesc fieldTy])
        | OverloadTy(overloads) ->
            new GenList<CSFunctionType>(List.map (makeCSFunction fieldDesc) overloads)
        | _ ->
            new GenList<CSFunctionType>([])
    | _ ->
        new GenList<CSFunctionType>([])

let getCallInfo (modules : seq<string*string*string*int64>) (lexp : Expr) (targetFileName : string) : GenList<CSFunctionType> =
    let ret = new GenList<CSFunctionType>()
    let stubCtxt = getStubContextInProject modules targetFileName
    let typed = typeExpr lexp
    let exprTy,_ = typeCheckExpr stubCtxt.DontTrackErrors.IsNotLeftExpr typed 
    match Type.Coerce stubCtxt.tenv exprTy with
    | CallableTy(desc,formals,rets,varargs,defLocation) as ty ->
        new GenList<CSFunctionType>([makeCSFunction "" ty])
    | OverloadTy(overloads) ->
        new GenList<CSFunctionType>(List.map (makeCSFunction "") overloads)        
    | _ ->
        new GenList<CSFunctionType>()

let getRecordInfo (modules : seq<string*string*string*int64>) (lexp : Expr) (targetFileName : string) : System.Object =
    let stubCtxt = getStubContextInProject modules targetFileName
    let typed = typeExpr lexp
    let stubCtxt = stubCtxt.DontTrackErrors.IsNotLeftExpr
    let exprTy,_ = typeCheckExpr stubCtxt typed
    match Type.Coerce stubCtxt.tenv exprTy with
    | RecordTy(name,desc,_,_,fields,methods,_)
    | OpenRecordTy(name,desc,_,_,fields,methods,_) ->
        // fieldList/methodList entries represent (name/type/description)
        let fieldList = new GenList<string*string*string>()
        for kv in fields do
            let name = kv.Key
            let field = kv.Value
            fieldList.Add(name,field.ty.ToString(),field.desc)
        
        let methodList = new GenList<string*string*string>()
        for kv in methods do
            let name = kv.Key
            let {desc=desc;ty=ty;isAbstract=_;loc=_} = kv.Value
            methodList.Add(name,ty.ToString(),desc)            
        
        {
            name = name
            desc = desc
            fields = fieldList
            methods = methodList    
        } :> System.Object
    | _ ->
        null


let public plugins = ref []

/// Copies all library modules from the UserData directory to the project directory
/// Returns a list of all library modules
let syncLibModules (projectDir : string) =
    let libModules = Set.ofSeq (Seq.collect (fun (x : ITypeCollectorPlugin) -> x.GetLibPaths()) !plugins)
    
    for modFile : string in libModules do
        // make sure the directory containing the file (in the project) exists 
        let dirChain = modFile.Split('\\')
        let dir = ref ""
        for i in 0 .. dirChain.Length-2 do
            dir := !dir + "\\" + dirChain.[i]

            if not (System.IO.Directory.Exists(projectDir + !dir)) then
                ignore (System.IO.Directory.CreateDirectory(projectDir + !dir))

        let writeTime = System.IO.File.GetLastWriteTime
        let exists = System.IO.File.Exists
        let projFile = projectDir + "\\" + modFile
        let pluginsFile = pluginsDir + "\\" + modFile

        // copy from plugin directory to project directory
        if (not (exists(projectDir + "\\" + modFile))) ||
           (not (writeTime(projectDir + "\\" + modFile) = writeTime(pluginsDir + "\\" + modFile))) then
            System.IO.File.Copy(pluginsDir + "\\" + modFile, projectDir + "\\" + modFile,true)
        
    libModules

let getProjectErrors (modules : seq<string*string*string*int64>) (projectDir : string) (typeCheck : bool) : GenList<string*string*Range> =
    let libModules = syncLibModules projectDir

    let modules' = seq {
        for fileName,modName,fileContents,timeStamp in modules do
            if not (libModules.Contains (fileName.Substring(projectDir.Length))) then
                yield fileName,modName,fileContents,timeStamp
    }   
    
    let errors = (LuaAnalyzer.ProjectChecker.typeCheckProject modules' typeCheck)
    errors

let isFileCollectedBy (modName : string) (fileName : string) (typeCollectorName : string) =
    match getTypeCollectorByName typeCollectorName with
    | Some collector ->
        let reader = new System.IO.StreamReader(fileName)
        let ast,_ = HandParser.parse (reader.ReadToEnd())
        let typed = TypedSyntax.typeStatement ast

        match collector.typeGraphBuilder modName fileName typed with
        | Some(_,_,_) ->
            true
        | None ->
            false
    | _ ->
        false

type Composite () =
         
    [<ImportMany>]
    [<DefaultValue>]
    val mutable public collectors : seq<ITypeCollectorPlugin>

    member self.init() =
        let catalog = new AggregateCatalog()
        catalog.Catalogs.Add(new DirectoryCatalog(pluginsDir))

        let container = new CompositionContainer(catalog)
        container.ComposeParts(self)        

/// Initialize all type collector plugins
let init () =
    let comp = new Composite()
    comp.init()
        
    for collector in comp.collectors do
        collector.Init()
        plugins := collector :: !plugins