[WIP] Witnesses for STRP resolution

.vscode/launch.json

@@ -22,11 +22,11 @@
             "type": "pwa-node"
         },
         {
-            "name": "Fable TCP server",
+            "name": "Fable.Cli",
             "type": "coreclr",
             "request": "launch",
-            "program": "${workspaceFolder}/src/Fable.Cli/bin/Debug/netcoreapp2.1/Fable.Cli.dll",
-            "args": ["start", "--port", "61225"],
+            "program": "${workspaceFolder}/src/Fable.Cli/bin/Debug/netcoreapp3.1/fable.dll",
+            "args": ["watch", "src/quicktest", "--exclude", "Fable.Core"],
             "cwd": "${workspaceFolder}",
             "stopAtEntry": false,
             "console": "internalConsole"

build.fsx

@@ -253,8 +253,8 @@ let test() =
     )
 
     runInDir "tests/Main" "dotnet run"
-    if envVarOrNone "APPVEYOR" |> Option.isSome then
-        testJs()
+    // if envVarOrNone "APPVEYOR" |> Option.isSome then
+    //     testJs()
 
 let coverage() =
     // report converter
@@ -302,30 +302,20 @@ let githubRelease() =
     | _ -> failwith "Expecting GITHUB_USER and GITHUB_TOKEN enviromental variables"
 
 let syncFcsRepo() =
-    // FAKE is giving lots of problems with the dotnet SDK version, ignore it
-    let cheatWithDotnetSdkVersion dir f =
-        let path = dir </> "build.fsx"
-        let script = readFile path
-        Regex.Replace(script, @"let dotnetExePath =[\s\S]*DotNetCli\.InstallDotNetSDK", "let dotnetExePath = \"dotnet\" //DotNetCli.InstallDotNetSDK") |> writeFile path
-        f ()
-        runInDir dir "git reset --hard"
-
     printfn "Expecting %s repo to be cloned at %s" FCS_REPO FCS_REPO_LOCAL
 
     // TODO: Prompt to reset --hard changes
     // service_slim
     runInDir FCS_REPO_LOCAL ("git checkout " + FCS_REPO_SERVICE_SLIM_BRANCH)
     runInDir FCS_REPO_LOCAL "git pull"
-    cheatWithDotnetSdkVersion (FCS_REPO_LOCAL </> "fcs") (fun () ->
-        runBashOrCmd (FCS_REPO_LOCAL </> "fcs") "build" "")
+    runBashOrCmd (FCS_REPO_LOCAL </> "fcs") "build" ""
     copyFile (FCS_REPO_LOCAL </> "artifacts/bin/fcs/Release/netstandard2.0/FSharp.Compiler.Service.dll")  "../fable/lib/fcs/"
     copyFile (FCS_REPO_LOCAL </> "artifacts/bin/fcs/Release/netstandard2.0/FSharp.Compiler.Service.xml")  "../fable/lib/fcs/"
 
     // fcs-fable
     runInDir FCS_REPO_LOCAL ("git checkout " + FCS_REPO_FABLE_BRANCH)
     runInDir FCS_REPO_LOCAL "git pull"
-    cheatWithDotnetSdkVersion (FCS_REPO_LOCAL </> "fcs") (fun () ->
-        runBashOrCmd (FCS_REPO_LOCAL </> "fcs") "build" "CodeGen.Fable")
+    runBashOrCmd (FCS_REPO_LOCAL </> "fcs") "build" "CodeGen.Fable"
     copyDirRecursive (FCS_REPO_LOCAL </> "fcs/fcs-fable") "src/fcs-fable"
     copyDirNonRecursive (FCS_REPO_LOCAL </> "src/absil") "src/fcs-fable/src/absil"
     copyDirNonRecursive (FCS_REPO_LOCAL </> "src/fsharp") "src/fcs-fable/src/fsharp"

src/Fable.Cli/Entry.fs

@@ -108,6 +108,7 @@ let run watchMode fsprojDirOrFilePath args =
                 | Error _ -> 1
 
 let clean args dir =
+    let mutable count = 0
     let ignoreDirs = set ["bin"; "obj"; "node_modules"]
     let ext =
         argValue "--extension" args
@@ -123,6 +124,7 @@ let clean args dir =
             if IO.File.Exists(file) then
                 IO.File.Delete(file)
                 Log.verbose(lazy ("Deleted " + file))
+                count <- count + 1
         )
 
         IO.Directory.GetDirectories(dir)
@@ -131,7 +133,7 @@ let clean args dir =
         |> Array.iter recClean
 
     recClean dir
-    Log.always("Clean completed!")
+    Log.always(sprintf "%i file%s cleaned!" count (if count = 1 then "" else "s"))
     0
 
 let (|SplitCommandArgs|) (xs: string list) =

src/Fable.Transforms/FSharp2Fable.Util.fs

@@ -205,6 +205,7 @@ type Context =
       BoundMemberThis: Fable.Ident option
       InlinePath: Log.InlinePath list
       CaptureBaseConsCall: (FSharpEntity * (Fable.Expr -> unit)) option
+      Witnesses: FSharpExpr list
     }
     static member Create(enclosingEntity, usedRootNames) =
         { Scope = []
@@ -219,6 +220,7 @@ type Context =
           BoundMemberThis = None
           InlinePath = []
           CaptureBaseConsCall = None
+          Witnesses = []
         }
 
 type IFableCompiler =

src/Fable.Transforms/FSharp2Fable.fs

@@ -90,88 +90,6 @@ let private transformNewUnion com ctx r fsType (unionCase: FSharpUnionCase) (arg
         let tag = unionCaseTag tdef unionCase
         Fable.NewUnion(argExprs, tag, FsEnt tdef, genArgs) |> makeValue r
 
-let private transformTraitCall com (ctx: Context) r typ (sourceTypes: FSharpType list) traitName (flags: MemberFlags) (argTypes: FSharpType list) (argExprs: FSharpExpr list) =
-    let makeCallInfo traitName entityFullName argTypes genArgs: Fable.ReplaceCallInfo =
-        { SignatureArgTypes = argTypes
-          DeclaringEntityFullName = entityFullName
-          HasSpread = false
-          IsModuleValue = false
-          // We only need this for types with own entries in Fable AST
-          // (no interfaces, see below) so it's safe to set this to false
-          IsInterface = false
-          CompiledName = traitName
-          OverloadSuffix = lazy ""
-          GenericArgs =
-            // TODO: Check the source F# entity to get the actual gen param names?
-            match genArgs with
-            | [] -> []
-            | [genArg] -> ["T", genArg]
-            | genArgs -> genArgs |> List.mapi (fun i genArg -> "T" + string i, genArg)
-        }
-
-    let resolveMemberCall (entity: Fable.Entity) genArgs membCompiledName isInstance argTypes thisArg args =
-        let genParamNames = entity.GenericParameters |> List.map (fun x -> x.Name)
-        let genArgs = List.zip genParamNames genArgs
-        tryFindMember com entity (Map genArgs) membCompiledName isInstance argTypes
-        |> Option.map (fun memb -> makeCallFrom com ctx r typ [] thisArg args memb)
-
-    let isInstance = flags.IsInstance
-    let argTypes = List.map (makeType ctx.GenericArgs) argTypes
-    let argExprs = List.map (fun e -> com.Transform(ctx, e)) argExprs
-    let thisArg, args, argTypes =
-        match argExprs, argTypes with
-        | thisArg::args, _::argTypes when isInstance -> Some thisArg, args, argTypes
-        | args, argTypes -> None, args, argTypes
-
-    sourceTypes |> Seq.tryPick (fun sourceType ->
-        let t = makeType ctx.GenericArgs sourceType
-        match t with
-        // Types with specific entry in Fable.AST
-        // TODO: Check other types like booleans or numbers?
-        | Fable.String ->
-            let info = makeCallInfo traitName Types.string argTypes []
-            Replacements.strings com ctx r typ info thisArg args
-        | Fable.Tuple genArgs ->
-            let info = makeCallInfo traitName (getTypeFullName false t) argTypes genArgs
-            Replacements.tuples com ctx r typ info thisArg args
-        | Fable.Option genArg ->
-            let info = makeCallInfo traitName Types.option argTypes [genArg]
-            Replacements.options com ctx r typ info thisArg args
-        | Fable.Array genArg ->
-            let info = makeCallInfo traitName Types.array argTypes [genArg]
-            Replacements.arrays com ctx r typ info thisArg args
-        | Fable.List genArg ->
-            let info = makeCallInfo traitName Types.list argTypes [genArg]
-            Replacements.lists com ctx r typ info thisArg args
-        // Declared types not in Fable AST
-        | Fable.DeclaredType(entity, genArgs) ->
-            // SRTP only works for records if there are no arguments
-            if isInstance && entity.IsFSharpRecord && List.isEmpty args && Option.isSome thisArg then
-                let fieldName = Naming.removeGetSetPrefix traitName
-                entity.FSharpFields |> Seq.tryPick (fun fi ->
-                    if fi.Name = fieldName then
-                        let kind = Fable.FieldKey(fi) |> Fable.ByKey
-                        Fable.Get(thisArg.Value, kind, typ, r) |> Some
-                    else None)
-                |> Option.orElseWith (fun () ->
-                    resolveMemberCall entity genArgs traitName isInstance argTypes thisArg args)
-            else resolveMemberCall entity genArgs traitName isInstance argTypes thisArg args
-        | Fable.AnonymousRecordType(sortedFieldNames, genArgs)
-                when isInstance && List.isEmpty args && Option.isSome thisArg ->
-            let fieldName = Naming.removeGetSetPrefix traitName
-            Seq.zip sortedFieldNames genArgs
-            |> Seq.tryPick (fun (fi, fiType) ->
-                if fi = fieldName then
-                    let kind =
-                        FsField(fi, lazy fiType) :> Fable.Field
-                        |> Fable.FieldKey
-                        |> Fable.ByKey
-                    Fable.Get(thisArg.Value, kind, typ, r) |> Some
-                else None)
-        | _ -> None
-    ) |> Option.defaultWith (fun () ->
-        "Cannot resolve trait call " + traitName |> addErrorAndReturnNull com ctx.InlinePath r)
-
 let private getAttachedMemberInfo com ctx r nonMangledNameConflicts
                 (declaringEntityName: string option) (sign: FSharpAbstractSignature) attributes =
     let declaringEntityName = defaultArg declaringEntityName ""
@@ -538,17 +456,66 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =
 
     // `argTypes2` is always empty
     | BasicPatterns.TraitCall(sourceTypes, traitName, flags, argTypes, _argTypes2, argExprs) ->
+        let r = makeRangeFrom fsExpr
         let typ = makeType ctx.GenericArgs fsExpr.Type
-        return transformTraitCall com ctx (makeRangeFrom fsExpr) typ sourceTypes traitName flags argTypes argExprs
+        let! args = transformExprList com ctx argExprs
+
+        match ctx.Witnesses with
+        | [witness] ->
+            // printfn "single witness for %s in context %A" traitName witness
+            let! callee = transformExpr com ctx witness
+            return Fable.CurriedApply(callee, args, typ, r)
+
+        | witnesses ->
+            // printfn "multiple witnesses for %s in context %A" traitName witnesses
+            let rec tryNestedLambda args = function
+                | BasicPatterns.Lambda(arg, body) -> tryNestedLambda (arg::args) body
+                | _ when List.isEmpty args -> None
+                | body -> Some(List.rev args, body)
+
+            let callee =
+                witnesses |> List.tryFind (fun e ->
+                    match tryNestedLambda [] e with
+                    | Some(lambdaArgs, _) when List.sameLength argTypes lambdaArgs ->
+                        argTypes = (lambdaArgs |> List.map (fun a -> a.FullType))
+                    | _ -> false)
+
+            match callee with
+            | Some callee ->
+                let! callee = transformExpr com ctx callee
+                return Fable.CurriedApply(callee, args, typ, r)
+            | None ->
+                return "Cannot resolve trait call: " + traitName
+                |> addErrorAndReturnNull com ctx.InlinePath r
 
-    | BasicPatterns.Call(callee, memb, ownerGenArgs, membGenArgs, args) ->
+    | BasicPatterns.CallWithWitnesses(callee, memb, ownerGenArgs, membGenArgs, witnesses, args) ->
         checkArgumentsPassedByRef com ctx args
+
+        let r = makeRangeFrom fsExpr
         let! callee = transformExprOpt com ctx callee
         let! args = transformExprList com ctx args
-        // TODO: Check answer to #868 in FSC repo
         let genArgs = ownerGenArgs @ membGenArgs |> Seq.map (makeType ctx.GenericArgs)
         let typ = makeType ctx.GenericArgs fsExpr.Type
-        return makeCallFrom com ctx (makeRangeFrom fsExpr) typ genArgs callee args memb
+
+        let ctx =
+            match witnesses with
+            | [] -> ctx
+            | witnesses ->
+                // printfn "passing witnesses to %s %A %A" memb.CompiledName witnesses ctx.Witnesses
+                witnesses |> List.map (function
+                    | BasicPatterns.WitnessArg i as w ->
+                        // TODO: The index doesn't seem to be reliable, it's -1 all the time
+                        let i = if i < 0 then 0 else i
+                        match List.tryItem i ctx.Witnesses with
+                        | Some e -> e
+                        | None ->
+                            // sprintf "Cannot find witness with index %i in context" i
+                            // |> addError com ctx.InlinePath r
+                            w
+                    | e -> e)
+                |> fun ws -> { ctx with Witnesses = ws }
+
+        return makeCallFrom com ctx r typ genArgs callee args memb
 
     | BasicPatterns.Application(applied, _genArgs, []) ->
         // TODO: Ask why application without arguments happen. So far I've seen it
@@ -570,7 +537,7 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =
                 let! args = transformExprList com ctx args
                 return Fable.CurriedApply(callee, args, typ, r)
         | None ->
-            return "Cannot resolve locally inlined value: " + var.DisplayName
+            return "Cannot resolve locally inlined lambda: " + var.DisplayName
             |> addErrorAndReturnNull com ctx.InlinePath r
 
     // When using Fable dynamic operator, we must untuple arguments

src/Fable.Transforms/Fable2Babel.fs

@@ -933,6 +933,7 @@ module Util =
                 then makeGenTypeParamInst com ctx genArgs
                 else None
             // let caseName = ent.UnionCases |> List.item tag |> getUnionCaseName |> ofString
+            // TODO: Add the tag name in a comment
             let values = (ofInt tag)::values |> List.toArray
             upcast NewExpression(consRef, values, ?typeArguments=typeParamInst, ?loc=r)
 

src/Fable.Transforms/MonadicTrampoline.fs

@@ -13,6 +13,11 @@ type TrampolineBuilder() =
     member __.Delay f = DelayValue f
     member __.Return a = ReturnValue a
     member __.ReturnFrom (a: Thunk<'T>) = a
+    member __.TryWith (a: Thunk<'T>, onError: exn -> Thunk<'T>) =
+        match a with
+        | DelayValue f -> DelayValue(fun () ->
+            try f() with e -> onError e)
+        | ReturnValue x -> ReturnValue x
 
 let trampoline = TrampolineBuilder()
 

src/Fable.Transforms/Replacements.fs

@@ -642,7 +642,7 @@ let applyOp (com: ICompiler) (ctx: Context) r t opName (args: Expr list) argType
         match opName, args with
         | Operators.addition, [left; right] -> binOp BinaryPlus left right
         | Operators.subtraction, [left; right] -> binOp BinaryMinus left right
-        | Operators.multiply, [left; right] -> binOp BinaryMultiply left right
+        | (Operators.multiply | Operators.multiplyDynamic), [left; right] -> binOp BinaryMultiply left right
         | (Operators.division | Operators.divideByInt), [left; right] ->
             match argTypes with
             // Floor result of integer divisions (see #172)
@@ -2062,6 +2062,7 @@ let errorStrings = function
 
 let languagePrimitives (com: ICompiler) (ctx: Context) r t (i: CallInfo) (thisArg: Expr option) (args: Expr list) =
     match i.CompiledName, args with
+    | "MultiplyDynamic", _
     | "DivideByInt", _ -> applyOp com ctx r t i.CompiledName args i.SignatureArgTypes i.GenericArgs |> Some
     | "GenericZero", _ -> getZero com ctx t |> Some
     | "GenericOne", _ -> getOne com ctx t |> Some

src/Fable.Transforms/Transforms.Util.fs

@@ -107,6 +107,7 @@ module Operators =
     let [<Literal>] logicalNot = "op_LogicalNot"
     let [<Literal>] unaryNegation = "op_UnaryNegation"
     let [<Literal>] divideByInt = "DivideByInt"
+    let [<Literal>] multiplyDynamic = "MultiplyDynamic"
 
     let [<Literal>] equality = "op_Equality"
     let [<Literal>] inequality = "op_Inequality"