diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 22ebc3ca4df..f80916c325e 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -3690,7 +3690,7 @@ let CodegenWitnessArgForTraitConstraint tcVal g amap m traitInfo = trackErrors { let ChooseTyparSolutionAndSolve css denv tp = let g = css.g let amap = css.amap - let max, m = ChooseTyparSolutionAndRange g amap tp + let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) diff --git a/src/Compiler/Checking/FindUnsolved.fs b/src/Compiler/Checking/FindUnsolved.fs index 26b34d50b19..997fb3f70b2 100644 --- a/src/Compiler/Checking/FindUnsolved.fs +++ b/src/Compiler/Checking/FindUnsolved.fs @@ -20,108 +20,108 @@ type env = | NoEnv let FindUnsolvedStackGuardDepth = StackGuard.GetDepthOption "FindUnsolved" /// The environment and collector -type cenv = - { g: TcGlobals - amap: Import.ImportMap - denv: DisplayEnv - mutable unsolved: Typars +type cenv = + { g: TcGlobals + amap: Import.ImportMap + denv: DisplayEnv + mutable unsolved: Typars stackGuard: StackGuard } override _.ToString() = "" /// Walk types, collecting type variables -let accTy cenv _env (fallbackRange: Range option) ty = +let accTy cenv _env (mFallback: range) ty = let normalizedTy = tryNormalizeMeasureInType cenv.g ty - (freeInType CollectTyparsNoCaching normalizedTy).FreeTypars |> Zset.iter (fun tp -> + (freeInType CollectTyparsNoCaching normalizedTy).FreeTypars |> Zset.iter (fun tp -> if (tp.Rigidity <> TyparRigidity.Rigid) then - match fallbackRange with - | Some r when tp.Range = Range.range0 -> tp.SetIdent (FSharp.Compiler.Syntax.Ident(tp.typar_id.idText, r)) + match mFallback with + | r when tp.Range = Range.range0 -> tp.SetIdent (FSharp.Compiler.Syntax.Ident(tp.typar_id.idText, r)) | _ -> () - cenv.unsolved <- tp :: cenv.unsolved) + cenv.unsolved <- tp :: cenv.unsolved) -let accTypeInst cenv env tyargs = - tyargs |> List.iter (accTy cenv env None) +let accTypeInst cenv env mFallback tyargs = + tyargs |> List.iter (accTy cenv env mFallback) /// Walk expressions, collecting type variables let rec accExpr (cenv: cenv) (env: env) expr = cenv.stackGuard.Guard <| fun () -> - let expr = stripExpr expr + let expr = stripExpr expr match expr with - | Expr.Sequential (e1, e2, _, _) -> - accExpr cenv env e1 + | Expr.Sequential (e1, e2, _, _) -> + accExpr cenv env e1 accExpr cenv env e2 - | Expr.Let (bind, body, _, _) -> - accBind cenv env bind + | Expr.Let (bind, body, _, _) -> + accBind cenv env bind accExpr cenv env body - | Expr.Const (_, r, ty) -> - accTy cenv env (Some r) ty - + | Expr.Const (_, r, ty) -> + accTy cenv env r ty + | Expr.Val (_v, _vFlags, _m) -> () - | Expr.Quote (ast, _, _, m, ty) -> + | Expr.Quote (ast, _, _, m, ty) -> accExpr cenv env ast - accTy cenv env (Some m) ty + accTy cenv env m ty - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> - accTy cenv env (Some m) ty + | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> + accTy cenv env m ty accExpr cenv env basecall - accMethods cenv env basev overrides - accIntfImpls cenv env basev iimpls + accMethods cenv env basev overrides + accIntfImpls cenv env basev m iimpls - | LinearOpExpr (_op, tyargs, argsHead, argLast, _m) -> + | LinearOpExpr (_op, tyargs, argsHead, argLast, m) -> // Note, LinearOpExpr doesn't include any of the "special" cases for accOp - accTypeInst cenv env tyargs + accTypeInst cenv env m tyargs accExprs cenv env argsHead // tailcall accExpr cenv env argLast | Expr.Op (c, tyargs, args, m) -> - accOp cenv env (c, tyargs, args, m) + accOp cenv env (c, tyargs, args, m) | Expr.App (f, fty, tyargs, argsl, m) -> - accTy cenv env (Some m) fty - accTypeInst cenv env tyargs + accTy cenv env m fty + accTypeInst cenv env m tyargs accExpr cenv env f accExprs cenv env argsl - | Expr.Lambda (_, _ctorThisValOpt, _baseValOpt, argvs, _body, m, bodyTy) -> - let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) - let ty = mkMultiLambdaTy cenv.g m argvs bodyTy + | Expr.Lambda (_, _ctorThisValOpt, _baseValOpt, argvs, _body, m, bodyTy) -> + let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) + let ty = mkMultiLambdaTy cenv.g m argvs bodyTy accLambdas cenv env valReprInfo expr ty - | Expr.TyLambda (_, tps, _body, m, bodyTy) -> - let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - accTy cenv env (Some m) bodyTy - let ty = mkForallTyIfNeeded tps bodyTy + | Expr.TyLambda (_, tps, _body, m, bodyTy) -> + let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) + accTy cenv env m bodyTy + let ty = mkForallTyIfNeeded tps bodyTy accLambdas cenv env valReprInfo expr ty - | Expr.TyChoose (_tps, e1, _m) -> - accExpr cenv env e1 + | Expr.TyChoose (_tps, e1, _m) -> + accExpr cenv env e1 - | Expr.Match (_, _exprm, dtree, targets, m, ty) -> - accTy cenv env (Some m) ty + | Expr.Match (_, _exprm, dtree, targets, m, ty) -> + accTy cenv env m ty accDTree cenv env dtree accTargets cenv env m ty targets - | Expr.LetRec (binds, e, _m, _) -> + | Expr.LetRec (binds, e, _m, _) -> accBinds cenv env binds accExpr cenv env e - | Expr.StaticOptimization (constraints, e2, e3, m) -> + | Expr.StaticOptimization (constraints, e2, e3, m) -> accExpr cenv env e2 accExpr cenv env e3 - constraints |> List.iter (function - | TTyconEqualsTycon(ty1, ty2) -> - accTy cenv env (Some m) ty1 - accTy cenv env (Some m) ty2 - | TTyconIsStruct(ty1) -> - accTy cenv env (Some m) ty1) + constraints |> List.iter (function + | TTyconEqualsTycon(ty1, ty2) -> + accTy cenv env m ty1 + accTy cenv env m ty2 + | TTyconIsStruct(ty1) -> + accTy cenv env m ty1) - | Expr.WitnessArg (traitInfo, _m) -> - accTraitInfo cenv env traitInfo + | Expr.WitnessArg (traitInfo, m) -> + accTraitInfo cenv env m traitInfo | Expr.Link eref -> accExpr cenv env eref.Value @@ -129,166 +129,166 @@ let rec accExpr (cenv: cenv) (env: env) expr = | Expr.DebugPoint (_, innerExpr) -> accExpr cenv env innerExpr -and accMethods cenv env baseValOpt l = +and accMethods cenv env baseValOpt l = List.iter (accMethod cenv env baseValOpt) l -and accMethod cenv env _baseValOpt (TObjExprMethod(_slotsig, _attribs, _tps, vs, bodyExpr, _m)) = +and accMethod cenv env _baseValOpt (TObjExprMethod(_slotsig, _attribs, _tps, vs, bodyExpr, _m)) = vs |> List.iterSquared (accVal cenv env) accExpr cenv env bodyExpr -and accIntfImpls cenv env baseValOpt l = - List.iter (accIntfImpl cenv env baseValOpt) l +and accIntfImpls cenv env baseValOpt (mFallback: range) l = + List.iter (accIntfImpl cenv env baseValOpt mFallback) l -and accIntfImpl cenv env baseValOpt (ty, overrides) = - accTy cenv env None ty - accMethods cenv env baseValOpt overrides +and accIntfImpl cenv env (baseValOpt: Val option) (mFallback: range) (ty, overrides) = + accTy cenv env mFallback ty + accMethods cenv env baseValOpt overrides -and accOp cenv env (op, tyargs, args, _m) = - // Special cases - accTypeInst cenv env tyargs +and accOp cenv env (op, tyargs, args, m) = + // Special cases + accTypeInst cenv env m tyargs accExprs cenv env args - match op with - // Handle these as special cases since mutables are allowed inside their bodies + match op with + // Handle these as special cases since mutables are allowed inside their bodies | TOp.ILCall (_, _, _, _, _, _, _, _, enclTypeInst, methInst, retTys) -> - accTypeInst cenv env enclTypeInst - accTypeInst cenv env methInst - accTypeInst cenv env retTys - | TOp.TraitCall traitInfo -> - accTraitInfo cenv env traitInfo - + accTypeInst cenv env m enclTypeInst + accTypeInst cenv env m methInst + accTypeInst cenv env m retTys + | TOp.TraitCall traitInfo -> + accTraitInfo cenv env m traitInfo + | TOp.ILAsm (_, retTys) -> - accTypeInst cenv env retTys + accTypeInst cenv env m retTys | _ -> () -and accTraitInfo cenv env (TTrait(tys, _nm, _, argTys, retTy, _sln)) = - argTys |> accTypeInst cenv env - retTy |> Option.iter (accTy cenv env None) - tys |> List.iter (accTy cenv env None) +and accTraitInfo cenv env (mFallback : range) (TTrait(tys, _nm, _, argTys, retTy, _sln)) = + argTys |> accTypeInst cenv env mFallback + retTy |> Option.iter (accTy cenv env mFallback) + tys |> List.iter (accTy cenv env mFallback) and accLambdas cenv env valReprInfo expr exprTy = match stripDebugPoints expr with - | Expr.TyChoose (_tps, bodyExpr, _m) -> accLambdas cenv env valReprInfo bodyExpr exprTy + | Expr.TyChoose (_tps, bodyExpr, _m) -> accLambdas cenv env valReprInfo bodyExpr exprTy | Expr.Lambda (range = range) | Expr.TyLambda (range = range) -> - let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo cenv.g cenv.amap valReprInfo (expr, exprTy) - accTy cenv env (Some range) bodyTy + let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo cenv.g cenv.amap valReprInfo (expr, exprTy) + accTy cenv env range bodyTy vsl |> List.iterSquared (accVal cenv env) baseValOpt |> Option.iter (accVal cenv env) ctorThisValOpt |> Option.iter (accVal cenv env) accExpr cenv env body - | _ -> + | _ -> accExpr cenv env expr -and accExprs cenv env exprs = - exprs |> List.iter (accExpr cenv env) +and accExprs cenv env exprs = + exprs |> List.iter (accExpr cenv env) -and accTargets cenv env m ty targets = +and accTargets cenv env m ty targets = Array.iter (accTarget cenv env m ty) targets -and accTarget cenv env _m _ty (TTarget(_vs, e, _)) = +and accTarget cenv env _m _ty (TTarget(_vs, e, _)) = accExpr cenv env e and accDTree cenv env dtree = - match dtree with + match dtree with | TDSuccess (es, _n) -> accExprs cenv env es - | TDBind(bind, rest) -> accBind cenv env bind; accDTree cenv env rest + | TDBind(bind, rest) -> accBind cenv env bind; accDTree cenv env rest | TDSwitch (e, cases, dflt, m) -> accSwitch cenv env (e, cases, dflt, m) -and accSwitch cenv env (e, cases, dflt, _m) = +and accSwitch cenv env (e, cases, dflt, m) = accExpr cenv env e - cases |> List.iter (fun (TCase(discrim, e)) -> accDiscrim cenv env discrim; accDTree cenv env e) - dflt |> Option.iter (accDTree cenv env) + cases |> List.iter (fun (TCase(discrim, e)) -> accDiscrim cenv env discrim m; accDTree cenv env e) + dflt |> Option.iter (accDTree cenv env) -and accDiscrim cenv env d = - match d with - | DecisionTreeTest.UnionCase(_ucref, tinst) -> accTypeInst cenv env tinst - | DecisionTreeTest.ArrayLength(_, ty) -> accTy cenv env None ty +and accDiscrim cenv env d mFallback = + match d with + | DecisionTreeTest.UnionCase(_ucref, tinst) -> accTypeInst cenv env mFallback tinst + | DecisionTreeTest.ArrayLength(_, ty) -> accTy cenv env mFallback ty | DecisionTreeTest.Const _ | DecisionTreeTest.IsNull -> () - | DecisionTreeTest.IsInst (srcTy, tgtTy) -> accTy cenv env None srcTy; accTy cenv env None tgtTy - | DecisionTreeTest.ActivePatternCase (exp, tys, _, _, _, _) -> + | DecisionTreeTest.IsInst (srcTy, tgtTy) -> accTy cenv env mFallback srcTy; accTy cenv env mFallback tgtTy + | DecisionTreeTest.ActivePatternCase (exp, tys, _, _, _, _) -> accExpr cenv env exp - accTypeInst cenv env tys + accTypeInst cenv env mFallback tys | DecisionTreeTest.Error _ -> () -and accAttrib cenv env (Attrib(_, _k, args, props, _, _, m)) = - args |> List.iter (fun (AttribExpr(expr1, expr2)) -> +and accAttrib cenv env (Attrib(_, _k, args, props, _, _, m)) = + args |> List.iter (fun (AttribExpr(expr1, expr2)) -> accExpr cenv env expr1 accExpr cenv env expr2) - props |> List.iter (fun (AttribNamedArg(_nm, ty, _flg, AttribExpr(expr, expr2))) -> + props |> List.iter (fun (AttribNamedArg(_nm, ty, _flg, AttribExpr(expr, expr2))) -> accExpr cenv env expr accExpr cenv env expr2 - accTy cenv env (Some m) ty) - -and accAttribs cenv env attribs = + accTy cenv env m ty) + +and accAttribs cenv env attribs = List.iter (accAttrib cenv env) attribs and accValReprInfo cenv env (ValReprInfo(_, args, ret)) = args |> List.iterSquared (accArgReprInfo cenv env) ret |> accArgReprInfo cenv env -and accArgReprInfo cenv env (argInfo: ArgReprInfo) = +and accArgReprInfo cenv env (argInfo: ArgReprInfo) = accAttribs cenv env argInfo.Attribs and accVal cenv env v = v.Attribs |> accAttribs cenv env v.ValReprInfo |> Option.iter (accValReprInfo cenv env) - v.Type |> accTy cenv env None + v.Type |> accTy cenv env v.Range and accBind cenv env (bind: Binding) = - accVal cenv env bind.Var + accVal cenv env bind.Var let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData accLambdas cenv env valReprInfo bind.Expr bind.Var.Type -and accBinds cenv env binds = - binds |> List.iter (accBind cenv env) +and accBinds cenv env binds = + binds |> List.iter (accBind cenv env) -let accTyconRecdField cenv env _tycon (rfield:RecdField) = +let accTyconRecdField cenv env _tycon (rfield:RecdField) = accAttribs cenv env rfield.PropertyAttribs accAttribs cenv env rfield.FieldAttribs let accTycon cenv env (tycon:Tycon) = accAttribs cenv env tycon.Attribs - abstractSlotValsOfTycons [tycon] |> List.iter (accVal cenv env) + abstractSlotValsOfTycons [tycon] |> List.iter (accVal cenv env) tycon.AllFieldsArray |> Array.iter (accTyconRecdField cenv env tycon) if tycon.IsUnionTycon then (* This covers finite unions. *) tycon.UnionCasesArray |> Array.iter (fun uc -> accAttribs cenv env uc.Attribs uc.RecdFieldsArray |> Array.iter (accTyconRecdField cenv env tycon)) -let accTycons cenv env tycons = +let accTycons cenv env tycons = List.iter (accTycon cenv env) tycons -let rec accModuleOrNamespaceDefs cenv env defs = +let rec accModuleOrNamespaceDefs cenv env defs = List.iter (accModuleOrNamespaceDef cenv env) defs -and accModuleOrNamespaceDef cenv env def = - match def with - | TMDefRec(_, _opens, tycons, mbinds, _m) -> +and accModuleOrNamespaceDef cenv env def = + match def with + | TMDefRec(_, _opens, tycons, mbinds, _m) -> accTycons cenv env tycons - accModuleOrNamespaceBinds cenv env mbinds - | TMDefLet(bind, _m) -> accBind cenv env bind + accModuleOrNamespaceBinds cenv env mbinds + | TMDefLet(bind, _m) -> accBind cenv env bind | TMDefDo(e, _m) -> accExpr cenv env e | TMDefOpens _ -> () - | TMDefs defs -> accModuleOrNamespaceDefs cenv env defs + | TMDefs defs -> accModuleOrNamespaceDefs cenv env defs -and accModuleOrNamespaceBinds cenv env xs = +and accModuleOrNamespaceBinds cenv env xs = List.iter (accModuleOrNamespaceBind cenv env) xs -and accModuleOrNamespaceBind cenv env x = - match x with - | ModuleOrNamespaceBinding.Binding bind -> +and accModuleOrNamespaceBind cenv env x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> accBind cenv env bind - | ModuleOrNamespaceBinding.Module(mspec, rhs) -> + | ModuleOrNamespaceBinding.Module(mspec, rhs) -> accTycon cenv env mspec - accModuleOrNamespaceDef cenv env rhs + accModuleOrNamespaceDef cenv env rhs let UnsolvedTyparsOfModuleDef g amap denv mdef extraAttribs = - let cenv = - { g =g - amap=amap - denv=denv - unsolved = [] + let cenv = + { g =g + amap=amap + denv=denv + unsolved = [] stackGuard = StackGuard(FindUnsolvedStackGuardDepth, "UnsolvedTyparsOfModuleDef") } accModuleOrNamespaceDef cenv NoEnv mdef accAttribs cenv NoEnv extraAttribs diff --git a/tests/FSharp.Test.Utilities/Compiler.fs b/tests/FSharp.Test.Utilities/Compiler.fs index db50005068c..c8adbc52e6e 100644 --- a/tests/FSharp.Test.Utilities/Compiler.fs +++ b/tests/FSharp.Test.Utilities/Compiler.fs @@ -290,12 +290,12 @@ module rec Compiler = let toErrorInfo (e: FSharpDiagnostic) : SourceCodeFileName * ErrorInfo = let errorNumber = e.ErrorNumber let severity = e.Severity - let error = + let error = match severity with | FSharpDiagnosticSeverity.Warning -> Warning errorNumber | FSharpDiagnosticSeverity.Error -> Error errorNumber | FSharpDiagnosticSeverity.Info -> Information errorNumber - | FSharpDiagnosticSeverity.Hidden -> Hidden errorNumber + | FSharpDiagnosticSeverity.Hidden -> Hidden errorNumber e.FileName |> Path.GetFileName, { Error = error @@ -415,7 +415,7 @@ module rec Compiler = | FS compilationSource -> FS { compilationSource with Source = compilationSource.Source.WithFileName(name) } | CS cSharpCompilationSource -> CS { cSharpCompilationSource with Source = cSharpCompilationSource.Source.WithFileName(name) } | IL _ -> failwith "IL Compilation cannot be named." - + let withReferenceFSharpCompilerService (cUnit: CompilationUnit) : CompilationUnit = // Compute the location of the FSharp.Compiler.Service dll that matches the target framework used to build this test assembly let compilerServiceAssemblyLocation = @@ -504,14 +504,14 @@ module rec Compiler = let withLangVersionPreview (cUnit: CompilationUnit) : CompilationUnit = withOptionsHelper [ "--langversion:preview" ] "withLangVersionPreview is only supported on F#" cUnit - + let withLangVersion (version: string) (cUnit: CompilationUnit) : CompilationUnit = withOptionsHelper [ $"--langversion:{version}" ] "withLangVersion is only supported on F#" cUnit let withAssemblyVersion (version:string) (cUnit: CompilationUnit) : CompilationUnit = withOptionsHelper [ $"--version:{version}" ] "withAssemblyVersion is only supported on F#" cUnit - let withWarnOn (cUnit: CompilationUnit) warning : CompilationUnit = + let withWarnOn warning (cUnit: CompilationUnit) : CompilationUnit = withOptionsHelper [ $"--warnon:{warning}" ] "withWarnOn is only supported for F#" cUnit let withNoWarn warning (cUnit: CompilationUnit) : CompilationUnit = @@ -584,14 +584,14 @@ module rec Compiler = | _ -> failwith "TODO: Implement where applicable." let asExe (cUnit: CompilationUnit) : CompilationUnit = - withOutputType CompileOutput.Exe cUnit - + withOutputType CompileOutput.Exe cUnit + let asLibrary (cUnit: CompilationUnit) : CompilationUnit = withOutputType CompileOutput.Library cUnit let asModule (cUnit: CompilationUnit) : CompilationUnit = - withOutputType CompileOutput.Module cUnit - + withOutputType CompileOutput.Module cUnit + let asNetStandard20 (cUnit: CompilationUnit) : CompilationUnit = match cUnit with | FS fs -> FS { fs with TargetFramework = TargetFramework.NetStandard20 } @@ -926,7 +926,7 @@ module rec Compiler = yield! fsSource.AdditionalSources |> List.map (fun source -> source.GetSourceFileName, source.GetSourceText) |] - + let getSourceText = let project = Map.ofArray sourceFiles fun (name: string) -> @@ -970,33 +970,33 @@ module rec Compiler = PerFileErrors = perFileDiagnostics Output = Some (EvalOutput evalResult) Compilation = FS fs } - + let evalError = match evalResult with Ok _ -> false | _ -> true - if evalError || errors.Length > 0 || (warnings.Length > 0 && not fs.IgnoreWarnings) then + if evalError || errors.Length > 0 || (warnings.Length > 0 && not fs.IgnoreWarnings) then CompilationResult.Failure result else CompilationResult.Success result - + let private evalFSharp (fs: FSharpCompilationSource) (script:FSharpScript) : CompilationResult = let source = fs.Source.GetSourceText |> Option.defaultValue "" - script.Eval(source) |> (processScriptResults fs) + script.Eval(source) |> (processScriptResults fs) let scriptingShim = Path.Combine(__SOURCE_DIRECTORY__,"ScriptingShims.fsx") let private evalScriptFromDisk (fs: FSharpCompilationSource) (script:FSharpScript) : CompilationResult = - - let fileNames = + + let fileNames = (fs.Source :: fs.AdditionalSources) |> List.map (fun x -> x.GetSourceFileName) |> List.insertAt 0 scriptingShim |> List.map (sprintf " @\"%s\"") |> String.Concat - script.Eval("#load " + fileNames ) |> (processScriptResults fs) + script.Eval("#load " + fileNames ) |> (processScriptResults fs) let eval (cUnit: CompilationUnit) : CompilationResult = match cUnit with - | FS fs -> + | FS fs -> let options = fs.Options |> Array.ofList use script = new FSharpScript(additionalArgs=options) evalFSharp fs script @@ -1168,7 +1168,7 @@ module rec Compiler = let result = regex.Replace(output, "") result - let stripEnvironment output = + let stripEnvironment output = let pattern = @"(---------------------------------------------------------------(\r\n|\r|\n)).*(\n---------------------------------------------------------------(\r\n|\r|\n))" let result = regexStrip output pattern (RegexOptions.Singleline ||| RegexOptions.ExplicitCapture) result @@ -1348,7 +1348,7 @@ module rec Compiler = failwith $"PDB file does not exists: {pdbPath}" | _ -> failwith "Output path is not set, please make sure compilation was successfull." match result with - | CompilationResult.Success r -> verifyPdbExists r + | CompilationResult.Success r -> verifyPdbExists r | _ -> failwith "Result should be \"Success\" in order to verify PDB." let verifyNoPdb (result: CompilationResult): unit = @@ -1360,7 +1360,7 @@ module rec Compiler = failwith $"PDB file exists: {pdbPath}" | _ -> failwith "Output path is not set, please make sure compilation was successfull." match result with - | CompilationResult.Success r -> verifyPdbNotExists r + | CompilationResult.Success r -> verifyPdbNotExists r | _ -> failwith "Result should be \"Success\" in order to verify PDB." [] @@ -1435,10 +1435,10 @@ module rec Compiler = match r.Output with | Some (ExecutionOutput output) -> sprintf "----output-----\n%s\n----error-------\n%s\n----------" output.StdOut output.StdErr - | Some (EvalOutput (Result.Error exn) ) -> + | Some (EvalOutput (Result.Error exn) ) -> sprintf "----script error-----\n%s\n----------" (exn.ToString()) - | Some (EvalOutput (Result.Ok fsiVal) ) -> - sprintf "----script output-----\n%A\n----------" (fsiVal) + | Some (EvalOutput (Result.Ok fsiVal) ) -> + sprintf "----script output-----\n%A\n----------" (fsiVal) | _ -> () ] |> String.concat "\n" failwith message @@ -1485,10 +1485,10 @@ module rec Compiler = let withError (expectedError: ErrorInfo) (result: CompilationResult) : CompilationResult = withErrors [expectedError] result - module StructuredResultsAsserts = - type SimpleErrorInfo = + module StructuredResultsAsserts = + type SimpleErrorInfo = { Error: ErrorType - Range: Range + Range: Range Message: string } let withResults (expectedResults: SimpleErrorInfo list) result : CompilationResult = @@ -1500,37 +1500,37 @@ module rec Compiler = - module TextBasedDiagnosticAsserts = + module TextBasedDiagnosticAsserts = open FSharp.Compiler.Text.Range - let private messageAndNumber errorType= + let private messageAndNumber errorType= match errorType with | ErrorType.Error n -> "error",n | ErrorType.Warning n-> "warning",n | ErrorType.Hidden n | ErrorType.Information n-> "info",n - let normalizeNewLines (s:string) = s.Replace("\r\n","\n").Replace("\n",Environment.NewLine) + let normalizeNewLines (s:string) = s.Replace("\r\n","\n").Replace("\n",Environment.NewLine) - let private renderToString (cr:CompilationResult) = + let private renderToString (cr:CompilationResult) = [ for (file,err) in cr.Output.PerFileErrors do let m = err.NativeRange let file = file.Replace("/", "\\") let severity,no = messageAndNumber err.Error let adjustedMessage = err.Message |> normalizeNewLines - let location = + let location = if (equals m range0) || (equals m rangeStartup) || (equals m rangeCmdArgs) then "" - else + else // The baseline .bsl files use 1-based notation for columns, hence the +1's sprintf "%s(%d,%d,%d,%d):" file m.StartLine (m.StartColumn+1) m.EndLine (m.EndColumn+1) Environment.NewLine + $"{location} {err.SubCategory} {severity} FS%04d{no}: {adjustedMessage}" + Environment.NewLine ] |> String.Concat - let withResultsMatchingFile (path:string) (result:CompilationResult) = + let withResultsMatchingFile (path:string) (result:CompilationResult) = let expectedContent = File.ReadAllText(path) |> normalizeNewLines - let actualErrors = renderToString result + let actualErrors = renderToString result match Environment.GetEnvironmentVariable("TEST_UPDATE_BSL") with | null -> () @@ -1538,9 +1538,9 @@ module rec Compiler = | _ -> File.WriteAllText(path, actualErrors) match Assert.shouldBeSameMultilineStringSets expectedContent actualErrors with - | None -> () + | None -> () | Some diff -> Assert.That(diff, Is.Empty, path) - + result let checkCodes (expected: int list) (selector: CompilationOutput -> ErrorInfo list) (result: CompilationResult) : CompilationResult = @@ -1693,6 +1693,6 @@ module rec Compiler = s.Replace("\r", "").Split('\n') |> Array.map (fun line -> line.TrimEnd()) |> String.concat "\n" - + let printSignatures cUnit = printSignaturesImpl None cUnit let printSignaturesWith pageWidth cUnit = printSignaturesImpl (Some pageWidth) cUnit