Source

love studio / ClassicTypeCollector / Main.fs

module Main

open LuaAnalyzer.Type
open LuaAnalyzer.TypeChecker
open LuaAnalyzer.TypedSyntax
open LuaAnalyzer.ErrorList
open LuaAnalyzer.Utils
open LuaAnalyzer.Context
open LuaAnalyzer.SubtypeGraphBuilder
open LuaAnalyzer.TypeCollector

open System.ComponentModel.Composition

exception GlobalStyleModuleDefinition of Range

let rec getName (currentFile : string) (ast : TypedStatement) =
    match ast with
    | LocalAssign(
        _,
        [NameExpr(name,rng)],
        [Constructor([],_)],
        _
      ) ->
        Some (name,rng)
    | Assign(
        _,
        [NameExpr(name,rng)],
        [Constructor([],_)],
        _
      ) ->
        raise( GlobalStyleModuleDefinition(rng) )
    | Sequence(s0,s1,_) ->
        let n0 = getName currentFile s0
        let n1 = getName currentFile s1

        match (n0,n1) with
        | ( Some (name0,range0), Some (name1,range1) ) ->
            addError
                currentFile 
                "multiple class definitions in file"
                range1
            addError
                currentFile
                "multiple class definitions in file"
                range0
            None
          | ( Some x , _ ) ->
            Some x
          | ( _ , Some x ) ->
            Some x
          | _ ->
            None 
    | _ ->
       None                    

type FieldMap = Map<string, Field>
type MethodMap = Map<string, Method>

let rec returnsName (name : string) (ast : TypedStatement) =
    match ast with
    | Sequence(s0,DoNothing(_),_) ->
        returnsName name s0
    | Sequence(s0,s1,_) ->
        returnsName name s1
    | Return([NameExpr(x,_)],_) when x = name ->
        true
    | _ ->
        false

let typeGraphBuilder (modPath : string) (fileName : string) (ast : TypedStatement) =
    try
        match getName fileName ast with
        | Some(name,rng) when returnsName name ast ->
            Some (rng,[],[])
        | Some(name,rng) ->
            addError 
                fileName
                ("Module table is not returned. Add return " + name + " to the end of this file")
                rng
            None
        | _ ->
            None
    with
    | GlobalStyleModuleDefinition(rng) ->
        addError fileName "Global style module definitions not allowed" rng
        None

let rec getFieldsAndMethods (fileName : string) (moduleName : string) (className : string) (ast : TypedStatement) : FieldMap*MethodMap =
    match ast with
    | Assign(
        annotation,
        [BinOpExpr(OpInd,NameExpr(x,_),String(fieldName,nameRng),_)], 
        [Function(desc,selfName,fstFormal :: restFormals,varargs,rets,body,(startLoc,_))],
        _
      ) when x = className ->
        let (fstName, fstDesc, fstType) = fstFormal

        if fstName = "self" then
            let methodTy = 
                FunctionTy(
                    desc, 
                    fstFormal :: restFormals,
                    rets, 
                    true, 
                    (fileName, nameRng)
                )

            Map.empty, new MethodMap([(fieldName,{desc=desc;ty=methodTy;isAbstract=false;loc=(fileName,nameRng)})])
        else
            let fieldTy = 
                FunctionTy(
                    desc, 
                    (fstName,fstDesc,fstType) :: restFormals,
                    rets, 
                    false, 
                    (fileName, nameRng)
                )

            new FieldMap([(fieldName,{desc = desc;ty=fieldTy;isConst = true;loc=(fileName,nameRng)})]), Map.empty
    | Assign(
        annotation,
        [BinOpExpr(OpInd,NameExpr(x,_),String(fieldName,nameRng),_)], 
        [Function(desc,selfName,[],varargs,rets,body,(startLoc,_))],
        _
      ) when x = className ->

        let fieldTy = 
            FunctionTy(
                desc, 
                [],
                rets, 
                false, 
                (fileName, nameRng)
            )
        
        new FieldMap([(fieldName,{desc=desc;ty=fieldTy;isConst=true;loc=(fileName,nameRng)})]), Map.empty
    | Assign(
        annotation,
        [BinOpExpr(OpInd,NameExpr(x,_),String(fieldName,nameRng),_)], 
        [expr],
        _
      ) when x = className ->
        let desc, vars, isConst = Type.InterpretVarAnnotation annotation 1

        match Type.InterpretVarAnnotation annotation 1 with
        | _,[None],[isConst] ->
            addError
                fileName 
                "non-function fields should be given type ascriptions"
                nameRng
            Map.empty, Map.empty
        | [desc],[Some(ty)],[isConst] ->
            new FieldMap([(fieldName,{desc=desc;ty=ty;isConst=isConst;loc=(fileName,nameRng)})]),Map.empty

    | Sequence(s0,s1,_) ->
        //TODO: detect duplicate method definitions
        let (f0,m0) = getFieldsAndMethods fileName moduleName className s0
        let (f1,m1) = getFieldsAndMethods fileName moduleName className s1
        (cover f0 f1, cover m0 m1)
    | _ ->
        Map.empty, Map.empty

let externalTypeBuilder (env : TypeEnvironment) (modname : string) (path : string) (ast : TypedStatement) =
    let typeMap = env.typeMap
    match getName path ast with
    | Some (name, rng) ->
        let fields, methods = getFieldsAndMethods path modname name ast
        let ty = RecordTy(
            modname,
            "", //TODO: we need to yoink module descriptions
            false,
            Closed,
            MetamethodSet.empty, 
            fields,
            methods,
            (path,rng)
        )

        // Note that for classic modules, the constructor type *is* the instance type
        Some (ty,ty)
    | _ ->
        raise( CollectorError "could not build external type" )

let internalTypeBuilder (ctxt : Context)
                        (modname : string) 
                        (fileName : string)
                        (ast : TypedStatement) =
    
    Map.empty

let decorate (ctxt : Context) (modname : string) (ast : TypedStatement) =
    let typeMap = ctxt.tenv.typeMap
    let (Some (className,_)) = getName "" ast

    let rec decRec (ast : TypedStatement) =
        match ast with
        | Sequence(s0,s1,rng) ->
            Sequence(decRec s0, decRec s1, rng)
        | LocalAssign(
            annotation,
            [NameExpr(name,nrng)],
            [Constructor([],crng)],
            rng
            ) ->

            let newClassTy = RecordTy(
                "*newmodule*",
                "a module in the process of being defined",
                true,
                Open,
                MetamethodSet.empty,
                Map.empty,
                Map.empty,
                NoLocation
            )

            LocalAssign(
                annotation,
                [NameExpr(name,nrng)],
                [Ascription(Constructor([],crng),newClassTy,crng)],
                rng
            ) 
        | Assign(
            annotation,
            [BinOpExpr(OpInd,NameExpr(x,rcl),String(methName,rmth),rind)], 
            [Function(desc,funcName,fstFormal :: restFormals,varargs,rets,body,funRng)],
            rng
            ) when x = className ->

            let (fstName,fstDesc,fstTy) = fstFormal
            
            if fstName = "self" then 
                let self' = "self","",ctxt.tenv.typeMap.Item modname

                Assign(
                    annotation,
                    [BinOpExpr(OpInd,NameExpr(x,rcl),String(methName,rmth),rind)],
                    [Function(desc,funcName,self' :: restFormals,varargs,rets,body,funRng)],
                    rng
                )
            else
                 Assign(
                    annotation,
                    [BinOpExpr(OpInd,NameExpr(x,rcl),String(methName,rmth),rind)],
                    [Function(desc,funcName,fstFormal :: restFormals,varargs,rets,body,funRng)],
                    rng
                )               
        | x ->
            x

    decRec ast

let detectMiscErrors (ctxt : Context) (modulePath : string) (filePath : string) (ast : TypedStatement) =
    ()

[<Export(typeof<LuaAnalyzer.Plugins.ITypeCollectorPlugin>)>]
type Initializer() =
    interface LuaAnalyzer.Plugins.ITypeCollectorPlugin with
        member self.Init () =
            addTypeCollector {
                name = "Classic Module System"
                typeGraphBuilder = typeGraphBuilder
                typeGraphIsTree = true
                externalTypeBuilder = externalTypeBuilder
                internalTypeBuilder = internalTypeBuilder
                decorate = decorate
                detectMiscErrors = detectMiscErrors
            }

        member self.GetLibPaths () =
            Seq.empty