Source

love studio / LoveStudio / LuaAnalyzer / BasePlugin.fs

Full commit
module LuaAnalyzer.BasePlugin

open Type
open Context
open TypeChecker

open System.Xml.Linq
open System.ComponentModel.Composition


let (!!) (str : string) =
    XName.Get(str)

/// Returns the value of the child element, or def if no such child element exists
let valOrDef (element : XElement) (name : XName) (def : string) =
    if element.Element(name) = null then
        def
    else
        element.Element(name).Value

let refReadType = 
    ref (fun (env : TypeEnvironment) (element : XElement) (isMethod : bool) -> UnknownTy)

let readType (env : TypeEnvironment) (element : XElement) (isMethod : bool) = 
    (!refReadType) env element isMethod

let readParameter (env : TypeEnvironment) (element : XElement) =
    let name = element.Element(!!"name").Value
    let desc = element.Element(!!"description").Value.Trim()
    let ty = readType env (element.Element(!!"type")) false
    (name,desc,ty)

let readRet (env : TypeEnvironment) (element : XElement) =
    let name = element.Element(!!"name").Value
    let desc = element.Element(!!"description").Value.Trim()
    let ty = readType env (element.Element(!!"type")) false
    (desc,ty)

let readFunctionType (env : TypeEnvironment) (element : XElement) (isMethod : bool) =
    let desc = valOrDef element !!"description" ""
    let parameters = element.Elements(!!"parameter")
    let rets = element.Elements(!!"return")
    FunctionTy(
        desc,
        List.map (readParameter env) (Seq.toList parameters),
        List.map (readRet env) (Seq.toList rets),
        isMethod,
        NoLocation
    )

let readField (env : TypeEnvironment) (element : XElement) =
    let name = element.Element(!!"name").Value
    let description = element.Element(!!"description").Value.Trim()
    let ty = readType env (element.Element(!!"type")) false
    let newField = {
        Field.OfType(ty) with
            desc = description
    }
    (name, newField)

let readMethod (env : TypeEnvironment) (element : XElement) =
    let name = element.Element(!!"name").Value
    let description = element.Element(!!"description").Value.Trim()
    let ty = readType env (element.Element(!!"type")) true

    match ty with
    | FunctionTy(tyDesc,formals,rets,true,loc) ->
        let newTy = 
            FunctionTy(
                tyDesc, 
                ("self","",UnknownTy) :: formals,
                rets,
                true,
                loc
            )

        (name, {desc=description;ty=newTy;isAbstract=false;loc=NoLocation})
    | UnknownTy ->
        (name, {desc=description;ty=UnknownTy;isAbstract=false;loc=NoLocation}) 
    | _ ->
        failwith "error reading XML: methods must have function type."
        
let readSuperType (env : TypeEnvironment) (element : XElement) =
    match Type.Unfold env (UserDefinedTy(element.Value)) with
    | RecordTy(_,_,_,_,fields,methods,_) ->
        fields,methods
    | UserDefinedTy(name) ->
        failwith ("type " + name + " not found")
    | _ ->
        failwith "only record types can be used as supertypes"

let readRecordSupertypeNames (element : XElement) =
    Seq.map (fun (x : XElement) -> x.Value) (element.Elements(!!"supertype")) 

let readRecordTy (env : TypeEnvironment) (element : XElement) =
    let name = element.Element(!!"name").Value
    let description = element.Element(!!"description").Value.Trim()

    let supertypes = Seq.map (readSuperType env) (element.Elements(!!"supertype"))
    let supertypeFieldsSeq = Seq.map fst supertypes
    let supertypeMethodsSeq = Seq.map snd supertypes

    //TODO: detect collisions
    let supertypeFields = Seq.fold cover Map.empty supertypeFieldsSeq
    let supertypeMethods = Seq.fold cover Map.empty supertypeMethodsSeq

    let fields = 
        if element.Element(!!"fields") = null then
            seq []
        else
            element.Element(!!"fields").Elements()

    let fields = new Map<string,Field>(List.map (readField env) (Seq.toList fields))
        
    let methods = 
        if element.Element(!!"methods") = null then
            seq []
        else
            element.Element(!!"methods").Elements()
        
    let methods = new Map<string,Method>(List.map (readMethod env) (Seq.toList methods))

    RecordTy(
        name, 
        description, 
        false,
        MetamethodSet.empty, 
        cover supertypeFields fields,
        cover supertypeMethods methods,
        NoLocation
    )

refReadType := fun (env : TypeEnvironment) (element : XElement) (isMethod : bool) ->
    let variant = element.Attribute(!!"variant").Value
    let nillable, variant = 
        if variant.[0] = '?' then
            true, variant.Substring(1)
        else
            false, variant

    let baseTy = 
        match variant with
        | "function" ->
            readFunctionType env element isMethod
        | "usertype" ->
            let name = element.Element(!!"name").Value
            Type.Unfold env (UserDefinedTy(name))
        | "overload" ->
            let overloads = ref []
            let overloadElements = element.Elements(!!"type")
            for overloadElement in overloadElements do
                overloads := (readType env overloadElement isMethod) :: !overloads
            OverloadTy(!overloads)
        | "unknown" ->
            UnknownTy
        | "record" ->
            readRecordTy env element
        | "number" ->
            NumberTy
        | "string" ->
            Type.Unfold env (UserDefinedTy("string"))
        | "boolean" ->
            BoolTy
        | _ ->
            UnknownTy

    if nillable then
        NillableTy(baseTy)
    else
        baseTy
    
let includeAPI (ctxt : Context) (fileName : string) =
    let reader = new System.Xml.XmlTextReader(fileName)    
    let root = XElement.Load(reader)
    
    let foldDefinition (env : TypeEnvironment) (typeDef : XElement) =
        let name = typeDef.Element(!!"name").Value
        {
        env with
            instanceTypes = env.instanceTypes.Add(name)
            typeMap = env.typeMap.Add(name, readType env typeDef false)
            edges = env.edges.Add(
                name,
                Seq.toList (readRecordSupertypeNames typeDef)
            )
        }

    let tenv = Seq.fold foldDefinition ctxt.tenv (root.Element(!!"TypeDefinitions").Elements())

    let foldGlobal (venv : ValueEnvironment) (def : XElement) =
        if def.Name = !!"global" then
            let globalId = def.Element(!!"name").Value
            let globalDesc = 
                if not (def.Element(!!"description") = null) then
                    def.Element(!!"description").Value
                else
                    ""
            let ty = readType tenv (def.Element(!!"type")) false
            let newField = {
                Field.OfType(Type.Unfold tenv ty) with
                    desc = globalDesc
            }

            venv.Add(globalId, newField)
        else
            venv

    let venv = Seq.fold foldGlobal ctxt.venv (root.Element(!!"globals").Elements())

    { 
        ctxt with
            venv = venv
            tenv = tenv
    }

let activateModule () =
    let ctxt = getBaseContext()
    let ctxt = includeAPI ctxt "LuaAPI.xml"
    
    let strTy = ctxt.tenv.typeMap.Item "string"
    let strTy =
        match strTy with
        | RecordTy(name,desc,_,metaset,fields,methods,defLocation) ->
            let metaset =
                {
                MetamethodSet.empty with
                    Concat = Some ("concatenate two strings", UserDefinedTy("string"), UserDefinedTy("string"))
                    Len = Some ("get the length of the string", NumberTy)
                    Eq = Some ("are these two strings equal?",UserDefinedTy("string"),BoolTy)
                    Ne = Some ("are these two strings unequal?",UserDefinedTy("string"),BoolTy)
                    Lt = Some ("is the left string lexicographically less than the right string?",UserDefinedTy("string"),BoolTy)
                    Le = Some ("is the left number lexicographically less than or equal to the right number?",UserDefinedTy("string"),BoolTy)
                    Gt = Some ("is the left number lexicographically greater than the right number?",UserDefinedTy("string"),BoolTy)
                    Ge = Some ("is the left number lexicographically less than or equal to the right number?",UserDefinedTy("string"),BoolTy)
                }
            RecordTy(name,desc,false,metaset,fields,methods,defLocation)
        | _ ->
            failwith "unreachable"

    let tenv = ctxt.tenv
    
    let tenv = 
        {
        tenv with
            typeMap = tenv.typeMap.Add("string",strTy)
        }
    
    let ctxt = 
        {
        ctxt with
            tenv = tenv
        }
    
    let ctxt = includeAPI ctxt "LoveAPI.xml"

    setBaseContext ctxt