1. kevinclancy
  2. love studio

Source

love studio / ClassicTypeCollector / Main.fs

The default branch has multiple heads

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,
            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 = OpenRecordTy(
                "*newmodule*",
                "a module in the process of being defined",
                true,
                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.Analyzer.ITypeCollectorPlugin>)>]
type Initializer() =
    interface LuaAnalyzer.Analyzer.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