From e1e4d6a8b17d45ef992e35d8609bea5967697897 Mon Sep 17 00:00:00 2001 From: dotnet bot Date: Tue, 31 May 2022 10:11:55 -0700 Subject: [PATCH] Merge main to release/dev17.3 (#13213) * update fantomas (#13206) * Format most of FSharp.Core (#13150) * modify fantomasignore * fix setting * no single line functions in FSHarp.Core * update fantomas * apply formatting * Format src/Compiler/Driver (#13195) * adjust settings * adjust code * adjust settings * adjust code * fix code before formatting * remove unnecessary yield * manual pre-formatting * preadjust code * preadjust code * preadjust code * preadjust code * adjust settings" * adjust settings" * adjust settings * adjust settings * fix build * adjust settings * adjust code * adjust code * adjust code * update fantomas * apply formatting * apply formatting (fix build) (#13209) * preformat * apply formatting Co-authored-by: Don Syme --- .config/dotnet-tools.json | 2 +- .editorconfig | 13 + .fantomasignore | 19 +- src/Compiler/AbstractIL/il.fs | 148 +- src/Compiler/AbstractIL/ilmorph.fs | 4 +- src/Compiler/AbstractIL/ilnativeres.fs | 24 +- src/Compiler/AbstractIL/ilprint.fs | 99 +- src/Compiler/AbstractIL/ilread.fs | 115 +- src/Compiler/AbstractIL/ilreflect.fs | 24 +- src/Compiler/AbstractIL/ilsign.fs | 26 +- src/Compiler/AbstractIL/ilsupp.fs | 18 +- src/Compiler/AbstractIL/ilwrite.fs | 7 +- src/Compiler/AbstractIL/ilwritepdb.fs | 44 +- src/Compiler/AbstractIL/ilx.fs | 5 +- .../Checking/AugmentWithHashCompare.fs | 16 +- src/Compiler/Checking/CheckDeclarations.fs | 21 +- src/Compiler/CodeGen/IlxGen.fs | 9 +- src/Compiler/Driver/BinaryResourceFormats.fs | 331 +- src/Compiler/Driver/CompilerConfig.fs | 1311 ++++--- src/Compiler/Driver/CompilerConfig.fsi | 6 +- src/Compiler/Driver/CompilerDiagnostics.fs | 3329 +++++++++-------- src/Compiler/Driver/CompilerImports.fs | 2492 +++++++----- src/Compiler/Driver/CompilerOptions.fs | 2846 ++++++++------ src/Compiler/Driver/CreateILModule.fs | 618 +-- src/Compiler/Driver/FxResolver.fs | 1211 +++--- src/Compiler/Driver/OptimizeInputs.fs | 182 +- src/Compiler/Driver/ParseAndCheckInputs.fs | 1170 +++--- src/Compiler/Driver/ScriptClosure.fs | 566 ++- src/Compiler/Driver/StaticLinking.fs | 788 ++-- src/Compiler/Driver/XmlDocFileWriter.fs | 46 +- src/Compiler/Driver/fsc.fs | 995 +++-- src/Compiler/Interactive/fsi.fs | 3 +- src/Compiler/Utilities/EditDistance.fs | 5 +- src/Compiler/Utilities/FileSystem.fs | 29 +- src/Compiler/Utilities/HashMultiMap.fs | 3 +- src/Compiler/Utilities/ImmutableArray.fs | 18 +- src/Compiler/Utilities/InternalCollections.fs | 18 +- src/Compiler/Utilities/QueueList.fs | 5 +- src/Compiler/Utilities/ResizeArray.fs | 9 +- src/Compiler/Utilities/TaggedCollections.fs | 90 +- src/Compiler/Utilities/illib.fs | 73 +- src/Compiler/Utilities/illib.fsi | 17 +- src/Compiler/Utilities/range.fs | 8 +- src/Compiler/Utilities/rational.fs | 20 +- src/Compiler/Utilities/sformat.fs | 50 +- .../CreateFSharpManifestResourceName.fs | 4 +- src/FSharp.Build/FSharpEmbedResXSource.fs | 3 +- src/FSharp.Build/FSharpEmbedResourceText.fs | 6 +- src/FSharp.Build/Fsc.fs | 7 +- src/FSharp.Build/Fsi.fs | 7 +- src/FSharp.Build/SubstituteText.fs | 4 +- src/FSharp.Build/WriteCodeFragment.fs | 3 +- .../fsiaux.fs | 4 +- src/FSharp.Core/.editorconfig | 6 + src/FSharp.Core/MutableTuple.fs | 160 +- src/FSharp.Core/Nullable.fs | 329 +- src/FSharp.Core/QueryExtensions.fs | 364 +- src/FSharp.Core/array.fs | 1696 ++++++--- src/FSharp.Core/async.fs | 1638 ++++---- src/FSharp.Core/collections.fs | 68 +- src/FSharp.Core/event.fs | 198 +- src/FSharp.Core/event.fsi | 3 +- src/FSharp.Core/eventmodule.fs | 87 +- src/FSharp.Core/fslib-extra-pervasives.fs | 476 ++- src/FSharp.Core/list.fs | 600 ++- src/FSharp.Core/local.fsi | 5 +- src/FSharp.Core/mailbox.fs | 245 +- src/FSharp.Core/map.fs | 1194 +++--- src/FSharp.Core/map.fsi | 10 +- src/FSharp.Core/math/z.fs | 114 +- src/FSharp.Core/observable.fs | 276 +- src/FSharp.Core/option.fs | 48 +- src/FSharp.Core/quotations.fs | 2505 ++++++++----- src/FSharp.Core/reflect.fs | 1159 +++--- src/FSharp.Core/result.fs | 15 +- src/FSharp.Core/resumable.fs | 278 +- src/FSharp.Core/seq.fs | 1196 +++--- src/FSharp.Core/seqcore.fsi | 4 +- src/FSharp.Core/set.fs | 1123 +++--- src/FSharp.Core/set.fsi | 8 +- src/FSharp.Core/string.fs | 98 +- src/FSharp.Core/tasks.fs | 366 +- .../FSharp.DependencyManager.ProjectFile.fs | 4 +- .../FSharp.DependencyManager.Utilities.fs | 17 +- .../FSharp.DependencyManager.fs | 12 +- src/fsc/fscmain.fs | 7 +- src/fsi/console.fs | 40 +- src/fsi/fsimain.fs | 46 +- 88 files changed, 18828 insertions(+), 12438 deletions(-) create mode 100644 src/FSharp.Core/.editorconfig diff --git a/.config/dotnet-tools.json b/.config/dotnet-tools.json index 927f1f5f8ee..b56be5549a4 100644 --- a/.config/dotnet-tools.json +++ b/.config/dotnet-tools.json @@ -3,7 +3,7 @@ "isRoot": true, "tools": { "fantomas": { - "version": "5.0.0-alpha-006", + "version": "5.0.0-alpha-008", "commands": [ "fantomas" ] diff --git a/.editorconfig b/.editorconfig index 5d68b1d516b..8f9f7fca164 100644 --- a/.editorconfig +++ b/.editorconfig @@ -1,8 +1,11 @@ root = true +# max_line_length is set to 140. At some point we will reduce it to 120 for as many files as reasonable. [*.fs] max_line_length=140 fsharp_newline_between_type_definition_and_members=true +fsharp_max_function_binding_width=40 +fsharp_max_if_then_else_short_width=60 fsharp_max_infix_operator_expression=80 fsharp_max_array_or_list_width=80 fsharp_max_array_or_list_number_of_items=5 @@ -13,3 +16,13 @@ fsharp_keep_max_number_of_blank_lines=1 [*.fsi] fsharp_newline_between_type_definition_and_members=true fsharp_keep_max_number_of_blank_lines=1 + +# These files contains many imperative if-then expressions which are not clearer on one line +# Reducing fsharp_max_if_then_else_short_width back to its default formats these over multiple lines. +[src/FSharp.Build/*.fs] +fsharp_max_if_then_else_short_width=40 + +# This file contains a long list of one-line function definitions. Increasing +# fsharp_max_function_binding_width formats these over a single line. +[src/Compiler/Driver/CompilerDiagnostics.fs] +fsharp_max_function_binding_width=70 diff --git a/.fantomasignore b/.fantomasignore index 1f44854852e..6fb09e40227 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -13,11 +13,9 @@ artifacts/ # Explicitly unformatted implementation files -src/FSharp.Core/**/*.fs src/Compiler/Checking/**/*.fs src/Compiler/CodeGen/**/*.fs src/Compiler/DependencyManager/**/*.fs -src/Compiler/Driver/**/*.fs src/Compiler/Facilities/**/*.fs src/Compiler/Interactive/**/*.fs src/Compiler/Legacy/**/*.fs @@ -28,6 +26,23 @@ src/Compiler/SyntaxTree/**/*.fs src/Compiler/TypedTree/**/*.fs src/Microsoft.FSharp.Compiler/**/*.fs +# Fantomas limitations on implementation files in FSharp.Core (to investigate) + +src/FSharp.Core/array2.fs +src/FSharp.Core/array3.fs +src/FSharp.Core/Linq.fs +src/FSharp.Core/local.fs +src/FSharp.Core/nativeptr.fs +src/FSharp.Core/prim-types-prelude.fs +src/FSharp.Core/prim-types.fs +src/FSharp.Core/printf.fs +src/FSharp.Core/Query.fs +src/FSharp.Core/seqcore.fs + +# Fantomas limitation https://github.com/fsprojects/fantomas/issues/2264 + +src/FSharp.Core/SI.fs + # Fantomas limitations on implementation files (to investigate) src/Compiler/AbstractIL/ilwrite.fs diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 3afa9326f47..ed951e0a03b 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -25,9 +25,7 @@ open Internal.Utilities let logging = false -let _ = - if logging then - dprintn "* warning: Il.logging is on" +let _ = if logging then dprintn "* warning: Il.logging is on" let int_order = LanguagePrimitives.FastGenericComparer @@ -70,19 +68,13 @@ let memoizeNamespaceRightTable = let memoizeNamespacePartTable = ConcurrentDictionary() let splitNameAt (nm: string) idx = - if idx < 0 then - failwith "splitNameAt: idx < 0" + if idx < 0 then failwith "splitNameAt: idx < 0" let last = nm.Length - 1 - if idx > last then - failwith "splitNameAt: idx > last" + if idx > last then failwith "splitNameAt: idx > last" - (nm.Substring(0, idx)), - (if idx < last then - nm.Substring(idx + 1, last - idx) - else - "") + (nm.Substring(0, idx)), (if idx < last then nm.Substring(idx + 1, last - idx) else "") let rec splitNamespaceAux (nm: string) = match nm.IndexOf '.' with @@ -218,14 +210,10 @@ module SHA1 = let inline (>>>&) (x: int) (y: int) = int32 (uint32 x >>> y) let f (t, b, c, d) = - if t < 20 then - (b &&& c) ||| ((~~~b) &&& d) - elif t < 40 then - b ^^^ c ^^^ d - elif t < 60 then - (b &&& c) ||| (b &&& d) ||| (c &&& d) - else - b ^^^ c ^^^ d + if t < 20 then (b &&& c) ||| ((~~~b) &&& d) + elif t < 40 then b ^^^ c ^^^ d + elif t < 60 then (b &&& c) ||| (b &&& d) ||| (c &&& d) + else b ^^^ c ^^^ d [] let k0to19 = 0x5A827999 @@ -563,8 +551,7 @@ type ILAssemblyRef(data) = addC (convDigit (int32 v / 16)) addC (convDigit (int32 v % 16)) // retargetable can be true only for system assemblies that definitely have Version - if aref.Retargetable then - add ", Retargetable=Yes" + if aref.Retargetable then add ", Retargetable=Yes" b.ToString() @@ -773,17 +760,9 @@ type ILTypeRef = else y.ApproxId - let xScope = - if isPrimaryX then - primaryScopeRef - else - x.Scope + let xScope = if isPrimaryX then primaryScopeRef else x.Scope - let yScope = - if isPrimaryY then - primaryScopeRef - else - y.Scope + let yScope = if isPrimaryY then primaryScopeRef else y.Scope (xApproxId = yApproxId) && (xScope = yScope) @@ -806,10 +785,7 @@ type ILTypeRef = else let c = compare x.Name y.Name - if c <> 0 then - c - else - compare x.Enclosing y.Enclosing + if c <> 0 then c else compare x.Enclosing y.Enclosing member tref.FullName = String.concat "." (tref.Enclosing @ [ tref.Name ]) @@ -883,11 +859,7 @@ and [" + x.TypeRef.ToString() + if isNil x.GenericArgs then "" else "<...>" and [] ILType = | Void @@ -1859,20 +1831,13 @@ type ILGenericParameterDefs = ILGenericParameterDef list let memberAccessOfFlags flags = let f = (flags &&& 0x00000007) - if f = 0x00000001 then - ILMemberAccess.Private - elif f = 0x00000006 then - ILMemberAccess.Public - elif f = 0x00000004 then - ILMemberAccess.Family - elif f = 0x00000002 then - ILMemberAccess.FamilyAndAssembly - elif f = 0x00000005 then - ILMemberAccess.FamilyOrAssembly - elif f = 0x00000003 then - ILMemberAccess.Assembly - else - ILMemberAccess.CompilerControlled + if f = 0x00000001 then ILMemberAccess.Private + elif f = 0x00000006 then ILMemberAccess.Public + elif f = 0x00000004 then ILMemberAccess.Family + elif f = 0x00000002 then ILMemberAccess.FamilyAndAssembly + elif f = 0x00000005 then ILMemberAccess.FamilyOrAssembly + elif f = 0x00000003 then ILMemberAccess.Assembly + else ILMemberAccess.CompilerControlled let convertMemberAccess (ilMemberAccess: ILMemberAccess) = match ilMemberAccess with @@ -2509,12 +2474,9 @@ let typeAccessOfFlags flags = let typeEncodingOfFlags flags = let f = (flags &&& 0x00030000) - if f = 0x00020000 then - ILDefaultPInvokeEncoding.Auto - elif f = 0x00010000 then - ILDefaultPInvokeEncoding.Unicode - else - ILDefaultPInvokeEncoding.Ansi + if f = 0x00020000 then ILDefaultPInvokeEncoding.Auto + elif f = 0x00010000 then ILDefaultPInvokeEncoding.Unicode + else ILDefaultPInvokeEncoding.Ansi [] type ILTypeDefKind = @@ -3613,32 +3575,20 @@ and rescopeILType scoref ty = | ILType.Boxed cr1 -> let cr2 = rescopeILTypeSpec scoref cr1 - if cr1 === cr2 then - ty - else - mkILBoxedType cr2 + if cr1 === cr2 then ty else mkILBoxedType cr2 | ILType.Array (s, ety1) -> let ety2 = rescopeILType scoref ety1 - if ety1 === ety2 then - ty - else - ILType.Array(s, ety2) + if ety1 === ety2 then ty else ILType.Array(s, ety2) | ILType.Value cr1 -> let cr2 = rescopeILTypeSpec scoref cr1 - if cr1 === cr2 then - ty - else - ILType.Value cr2 + if cr1 === cr2 then ty else ILType.Value cr2 | ILType.Modified (b, tref, ty) -> ILType.Modified(b, rescopeILTypeRef scoref tref, rescopeILType scoref ty) | x -> x and rescopeILTypes scoref i = - if isNil i then - i - else - List.mapq (rescopeILType scoref) i + if isNil i then i else List.mapq (rescopeILType scoref) i and rescopeILCallSig scoref csig = mkILCallSig (csig.CallingConv, rescopeILTypes scoref csig.ArgTypes, rescopeILType scoref csig.ReturnType) @@ -3933,13 +3883,7 @@ let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) = let dict = Dictionary.newWithSize c2.Labels.Count for kvp in c2.Labels do - dict.Add( - kvp.Key, - if kvp.Value = 0 then - 0 - else - kvp.Value + n - ) + dict.Add(kvp.Key, (if kvp.Value = 0 then 0 else kvp.Value + n)) dict @@ -4013,22 +3957,10 @@ let mkILField (isStatic, nm, ty, init: ILFieldInit option, at: byte[] option, ac fieldType = ty, attributes = (convertFieldAccess access - ||| (if isStatic then - FieldAttributes.Static - else - enum 0) - ||| (if isLiteral then - FieldAttributes.Literal - else - enum 0) - ||| (if init.IsSome then - FieldAttributes.HasDefault - else - enum 0) - ||| (if at.IsSome then - FieldAttributes.HasFieldRVA - else - enum 0)), + ||| (if isStatic then FieldAttributes.Static else enum 0) + ||| (if isLiteral then FieldAttributes.Literal else enum 0) + ||| (if init.IsSome then FieldAttributes.HasDefault else enum 0) + ||| (if at.IsSome then FieldAttributes.HasFieldRVA else enum 0)), literalValue = init, data = at, offset = None, @@ -4362,12 +4294,7 @@ let mkCtorMethSpecForDelegate (ilg: ILGlobals) (ty: ILType, useUIntPtr) = let argTys = [ rescopeILType scoref ilg.typ_Object - rescopeILType - scoref - (if useUIntPtr then - ilg.typ_UIntPtr - else - ilg.typ_IntPtr) + rescopeILType scoref (if useUIntPtr then ilg.typ_UIntPtr else ilg.typ_IntPtr) ] mkILInstanceMethSpecInTy (ty, ".ctor", argTys, ILType.Void, emptyILGenericArgsList) @@ -5143,8 +5070,8 @@ let decodeILAttribData (ca: ILAttribute) = try let parser = ILTypeSigParser n parser.ParseTypeSpec(), sigptr - with - | exn -> failwith (sprintf "decodeILAttribData: error parsing type in custom attribute blob: %s" exn.Message) + with exn -> + failwith (sprintf "decodeILAttribData: error parsing type in custom attribute blob: %s" exn.Message) | ILType.Boxed tspec when tspec.Name = "System.Object" -> let et, sigptr = sigptr_get_u8 bytes sigptr @@ -5605,10 +5532,7 @@ and unscopeILType ty = | x -> x and unscopeILTypes i = - if List.isEmpty i then - i - else - List.map unscopeILType i + if List.isEmpty i then i else List.map unscopeILType i and unscopeILCallSig csig = mkILCallSig (csig.CallingConv, unscopeILTypes csig.ArgTypes, unscopeILType csig.ReturnType) diff --git a/src/Compiler/AbstractIL/ilmorph.fs b/src/Compiler/AbstractIL/ilmorph.fs index dd60d94d0fc..08bd3a292c6 100644 --- a/src/Compiler/AbstractIL/ilmorph.fs +++ b/src/Compiler/AbstractIL/ilmorph.fs @@ -184,8 +184,8 @@ let cattr_ty2ty f (c: ILAttribute) = let elems = elems |> List.map (celem_ty2ty f) let namedArgs = namedArgs |> List.map (cnamedarg_ty2ty f) mkILCustomAttribMethRef (meth, elems, namedArgs) - with - | _ -> c.WithMethod(meth) + with _ -> + c.WithMethod(meth) else c.WithMethod(meth) diff --git a/src/Compiler/AbstractIL/ilnativeres.fs b/src/Compiler/AbstractIL/ilnativeres.fs index 8bbf79f9afc..3c0752ea8db 100644 --- a/src/Compiler/AbstractIL/ilnativeres.fs +++ b/src/Compiler/AbstractIL/ilnativeres.fs @@ -253,8 +253,8 @@ type COFFResourceReader() = if int64 relocLastAddress > stream.Length then raise <| ResourceException "CoffResourceInvalidRelocation" - with - | :? OverflowException -> (raise <| ResourceException("CoffResourceInvalidRelocation")) + with :? OverflowException -> + (raise <| ResourceException("CoffResourceInvalidRelocation")) let mutable relocationOffsets = Array.zeroCreate (int rsrc1.NumberOfRelocations) @@ -284,8 +284,8 @@ type COFFResourceReader() = if lastSymAddress > stream.Length then raise <| ResourceException "CoffResourceInvalidSymbol" - with - | :? OverflowException -> (raise <| ResourceException("CoffResourceInvalidSymbol")) + with :? OverflowException -> + (raise <| ResourceException("CoffResourceInvalidSymbol")) let mutable outputStream = new MemoryStream(imageResourceSectionBytes) let mutable writer = new BinaryWriter(outputStream) @@ -400,10 +400,7 @@ type VersionHelper() = let mutable (values: uint16[]) = Array.zeroCreate 4 let mutable (lastExplicitValue: int) = - if hasWildcard then - elements.Length - 1 - else - elements.Length + if hasWildcard then elements.Length - 1 else elements.Length let mutable (parseError: bool) = false let mutable earlyReturn = None @@ -1147,19 +1144,12 @@ type NativeResourceWriter() = dataWriter.WriteByte 0uy false - | e -> - failwithf - "Unknown entry %s" - (if isNull e then - "" - else - e.GetType().FullName) + | e -> failwithf "Unknown entry %s" (if isNull e then "" else e.GetType().FullName) if id >= 0 then writer.WriteInt32 id else - if name = Unchecked.defaultof<_> then - name <- String.Empty + if name = Unchecked.defaultof<_> then name <- String.Empty writer.WriteUInt32(nameOffset ||| 0x80000000u) dataWriter.WriteUInt16(uint16 name.Length) diff --git a/src/Compiler/AbstractIL/ilprint.fs b/src/Compiler/AbstractIL/ilprint.fs index 71efc7e0c4b..a9f95cbc1b0 100644 --- a/src/Compiler/AbstractIL/ilprint.fs +++ b/src/Compiler/AbstractIL/ilprint.fs @@ -661,20 +661,16 @@ let goutput_fdef _tref env os (fd: ILFieldDef) = output_member_access os fd.Access output_string os " " - if fd.IsStatic then - output_string os " static " + if fd.IsStatic then output_string os " static " - if fd.IsLiteral then - output_string os " literal " + if fd.IsLiteral then output_string os " literal " if fd.IsSpecialName then output_string os " specialname rtspecialname " - if fd.IsInitOnly then - output_string os " initonly " + if fd.IsInitOnly then output_string os " initonly " - if fd.NotSerialized then - output_string os " notserialized " + if fd.NotSerialized then output_string os " notserialized " goutput_typ env os fd.FieldType output_string os " " @@ -744,8 +740,7 @@ let output_code_label os lab = output_string os (formatCodeLabel lab) let goutput_local env os (l: ILLocal) = goutput_typ env os l.Type - if l.IsPinned then - output_string os " pinned" + if l.IsPinned then output_string os " pinned" let goutput_param env os (l: ILParameter) = match l.Name with @@ -990,8 +985,7 @@ let rec goutput_instr env os inst = let rank = shape.Rank output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) | I_ldelema (ro, _, shape, tok) -> - if ro = ReadonlyAddress then - output_string os "readonly. " + if ro = ReadonlyAddress then output_string os "readonly. " if shape = ILArrayShape.SingleDimensional then output_string os "ldelema " @@ -1040,8 +1034,7 @@ let rec goutput_instr env os inst = | _ -> output_string os "" let goutput_ilmbody env os (il: ILMethodBody) = - if il.IsZeroInit then - output_string os " .zeroinit\n" + if il.IsZeroInit then output_string os " .zeroinit\n" output_string os " .maxstack " output_i32 os il.MaxStack @@ -1060,21 +1053,11 @@ let goutput_mbody is_entrypoint env os (md: ILMethodDef) = else output_string os "runtime " - output_string - os - (if md.IsInternalCall then - "internalcall " - else - " ") + output_string os (if md.IsInternalCall then "internalcall " else " ") output_string os (if md.IsManaged then "managed " else " ") - output_string - os - (if md.IsForwardRef then - "forwardref " - else - " ") + output_string os (if md.IsForwardRef then "forwardref " else " ") output_string os " \n{ \n" goutput_security_decls env os md.SecurityDecls @@ -1084,8 +1067,7 @@ let goutput_mbody is_entrypoint env os (md: ILMethodDef) = | MethodBody.IL il -> goutput_ilmbody env os il.Value | _ -> () - if is_entrypoint then - output_string os " .entrypoint" + if is_entrypoint then output_string os " .entrypoint" output_string os "\n" output_string os "}\n" @@ -1096,14 +1078,8 @@ let goutput_mdef env os (md: ILMethodDef) = "virtual " + (if md.IsFinal then "final " else "") + (if md.IsNewSlot then "newslot " else "") - + (if md.IsCheckAccessOnOverride then - " strict " - else - "") - + (if md.IsAbstract then - " abstract " - else - "") + + (if md.IsCheckAccessOnOverride then " strict " else "") + + (if md.IsAbstract then " abstract " else "") + " " elif md.IsNonVirtualInstance then "" @@ -1136,14 +1112,8 @@ let goutput_mdef env os (md: ILMethodDef) = | PInvokeCharEncoding.Auto -> " autochar") + - (if attr.NoMangle then - " nomangle" - else - "") - + (if attr.LastError then - " lasterr" - else - "") + (if attr.NoMangle then " nomangle" else "") + + (if attr.LastError then " lasterr" else "") + ")" | _ -> "") elif md.IsClassInitializer then @@ -1155,14 +1125,11 @@ let goutput_mdef env os (md: ILMethodDef) = let menv = ppenv_enter_method (List.length md.GenericParams) env output_string os " .method " - if md.IsHideBySig then - output_string os "hidebysig " + if md.IsHideBySig then output_string os "hidebysig " - if md.IsReqSecObj then - output_string os "reqsecobj " + if md.IsReqSecObj then output_string os "reqsecobj " - if md.IsSpecialName then - output_string os "specialname " + if md.IsSpecialName then output_string os "specialname " if md.IsUnmanagedExport then output_string os "unmanagedexp " @@ -1182,17 +1149,13 @@ let goutput_mdef env os (md: ILMethodDef) = (goutput_params menv) os md.Parameters output_string os " " - if md.IsSynchronized then - output_string os "synchronized " + if md.IsSynchronized then output_string os "synchronized " - if md.IsMustRun then - output_string os "/* mustrun */ " + if md.IsMustRun then output_string os "/* mustrun */ " - if md.IsPreserveSig then - output_string os "preservesig " + if md.IsPreserveSig then output_string os "preservesig " - if md.IsNoInline then - output_string os "noinlining " + if md.IsNoInline then output_string os "noinlining " if md.IsAggressiveInline then output_string os "aggressiveinlining " @@ -1292,17 +1255,13 @@ let rec goutput_tdef enc env contents os (cd: ILTypeDef) = output_string os layout_attr output_string os " " - if cd.IsSealed then - output_string os "sealed " + if cd.IsSealed then output_string os "sealed " - if cd.IsAbstract then - output_string os "abstract " + if cd.IsAbstract then output_string os "abstract " - if cd.IsSerializable then - output_string os "serializable " + if cd.IsSerializable then output_string os "serializable " - if cd.IsComInterop then - output_string os "import " + if cd.IsComInterop then output_string os "import " output_sqstring os cd.Name goutput_gparams env os cd.GenericParams @@ -1380,8 +1339,7 @@ let output_assemblyRef os (aref: ILAssemblyRef) = output_string os " .assembly extern " output_sqstring os aref.Name - if aref.Retargetable then - output_string os " retargetable " + if aref.Retargetable then output_string os " retargetable " output_string os " { " output_option output_hash os aref.Hash @@ -1470,10 +1428,7 @@ let goutput_module_manifest env os modul = os ((if modul.IsILOnly then 0x0001 else 0) ||| (if modul.Is32Bit then 0x0002 else 0) - ||| (if modul.Is32BitPreferred then - 0x00020003 - else - 0)) + ||| (if modul.Is32BitPreferred then 0x00020003 else 0)) List.iter (fun r -> goutput_resource env os r) (modul.Resources.AsList()) output_string os "\n" diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index 022d5eeb839..dd32b630c70 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -41,15 +41,15 @@ let _ = let noStableFileHeuristic = try (Environment.GetEnvironmentVariable("FSharp_NoStableFileHeuristic") <> null) - with - | _ -> false + with _ -> + false let alwaysMemoryMapFSC = try (Environment.GetEnvironmentVariable("FSharp_AlwaysMemoryMapCommandLineCompiler") <> null) - with - | _ -> false + with _ -> + false let stronglyHeldReaderCacheSizeDefault = 30 @@ -58,8 +58,8 @@ let stronglyHeldReaderCacheSize = (match Environment.GetEnvironmentVariable("FSharp_StronglyHeldBinaryReaderCacheSize") with | null -> stronglyHeldReaderCacheSizeDefault | s -> int32 s) - with - | _ -> stronglyHeldReaderCacheSizeDefault + with _ -> + stronglyHeldReaderCacheSizeDefault let singleOfBits (x: int32) = BitConverter.ToSingle(BitConverter.GetBytes x, 0) @@ -101,12 +101,9 @@ let uncodedTokenToTypeDefOrRefOrSpec (tab, tok) = let uncodedTokenToMethodDefOrRef (tab, tok) = let tag = - if tab = TableNames.Method then - mdor_MethodDef - elif tab = TableNames.MemberRef then - mdor_MemberRef - else - failwith "bad table in uncodedTokenToMethodDefOrRef" + if tab = TableNames.Method then mdor_MethodDef + elif tab = TableNames.MemberRef then mdor_MemberRef + else failwith "bad table in uncodedTokenToMethodDefOrRef" TaggedIndex(tag, tok) @@ -1382,8 +1379,7 @@ let seekReadGuidIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadId let seekReadBlobIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadIdx ctxt.blobsBigness mdv &addr let seekReadModuleRow (ctxt: ILMetadataReader) mdv idx = - if idx = 0 then - failwith "cannot read Module table row 0" + if idx = 0 then failwith "cannot read Module table row 0" let mutable addr = ctxt.rowAddr TableNames.Module idx let generation = seekReadUInt16Adv mdv &addr @@ -1695,10 +1691,7 @@ let readStringHeapUncached ctxtH idx = let readStringHeap (ctxt: ILMetadataReader) idx = ctxt.readStringHeap idx let readStringHeapOption (ctxt: ILMetadataReader) idx = - if idx = 0 then - None - else - Some(readStringHeap ctxt idx) + if idx = 0 then None else Some(readStringHeap ctxt idx) let readBlobHeapUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH @@ -1713,10 +1706,7 @@ let readBlobHeapUncached ctxtH idx = let readBlobHeap (ctxt: ILMetadataReader) idx = ctxt.readBlobHeap idx let readBlobHeapOption ctxt idx = - if idx = 0 then - None - else - Some(readBlobHeap ctxt idx) + if idx = 0 then None else Some(readBlobHeap ctxt idx) //let readGuidHeap ctxt idx = seekReadGuid ctxt.mdv (ctxt.guidsStreamPhysicalLoc + idx) @@ -2210,14 +2200,10 @@ and seekReadGenericParamsUncached ctxtH (GenericParamsIdx (numTypars, a, b)) = let variance_flags = flags &&& 0x0003 let variance = - if variance_flags = 0x0000 then - NonVariant - elif variance_flags = 0x0001 then - CoVariant - elif variance_flags = 0x0002 then - ContraVariant - else - NonVariant + if variance_flags = 0x0000 then NonVariant + elif variance_flags = 0x0001 then CoVariant + elif variance_flags = 0x0002 then ContraVariant + else NonVariant let constraints = seekReadGenericParamConstraints ctxt mdv numTypars gpidx @@ -2522,16 +2508,7 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = let struct (n, sigptr) = sigptrGetZInt32 bytes sigptr let argTys, sigptr = sigptrFold (sigptrGetTy ctxt numTypars) n bytes sigptr - seekReadTypeDefOrRef - ctxt - numTypars - (if b0 = et_CLASS then - AsObject - else - AsValue) - argTys - tdorIdx, - sigptr + seekReadTypeDefOrRef ctxt numTypars (if b0 = et_CLASS then AsObject else AsValue) argTys tdorIdx, sigptr elif b0 = et_CLASS then let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr @@ -2570,10 +2547,7 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = Some(List.item i lobounds) else None), - (if i < numSized then - Some(List.item i sizes) - else - None) + (if i < numSized then Some(List.item i sizes) else None) ILArrayShape(List.init rank dim) @@ -2591,8 +2565,7 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = let ccByte, sigptr = sigptrGetByte bytes sigptr let generic, cc = byteAsCallConv ccByte - if generic then - failwith "fptr sig may not be generic" + if generic then failwith "fptr sig may not be generic" let struct (numparams, sigptr) = sigptrGetZInt32 bytes sigptr let retTy, sigptr = sigptrGetTy ctxt numTypars bytes sigptr @@ -2632,10 +2605,7 @@ and sigptrGetLocal (ctxt: ILMetadataReader) numTypars bytes sigptr = let pinned, sigptr = let b0, sigptr' = sigptrGetByte bytes sigptr - if b0 = et_PINNED then - true, sigptr' - else - false, sigptr + if b0 = et_PINNED then true, sigptr' else false, sigptr let ty, sigptr = sigptrGetTy ctxt numTypars bytes sigptr @@ -2844,12 +2814,9 @@ and seekReadMethodDefAsMethodDataUncached ctxtH idx = (fun i -> i, seekReadTypeDefRowWithExtents ctxt i), (fun r -> r), (fun (_, ((_, _, _, _, _, methodsIdx), (_, endMethodsIdx))) -> - if endMethodsIdx <= idx then - 1 - elif methodsIdx <= idx && idx < endMethodsIdx then - 0 - else - -1), + if endMethodsIdx <= idx then 1 + elif methodsIdx <= idx && idx < endMethodsIdx then 0 + else -1), true, fst ) @@ -2895,12 +2862,9 @@ and seekReadFieldDefAsFieldSpecUncached ctxtH idx = (fun i -> i, seekReadTypeDefRowWithExtents ctxt i), (fun r -> r), (fun (_, ((_, _, _, _, fieldsIdx, _), (endFieldsIdx, _))) -> - if endFieldsIdx <= idx then - 1 - elif fieldsIdx <= idx && idx < endFieldsIdx then - 0 - else - -1), + if endFieldsIdx <= idx then 1 + elif fieldsIdx <= idx && idx < endFieldsIdx then 0 + else -1), true, fst ) @@ -3619,10 +3583,7 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start s dprintn ( "invalid instruction: " + string lastb - + (if lastb = 0xfe then - ", " + string lastb2 - else - "") + + (if lastb = 0xfe then ", " + string lastb2 else "") ) I_ret @@ -3719,8 +3680,7 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int let isFatFormat = (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat if not isTinyFormat && not isFatFormat then - if logging then - failwith "unknown format" + if logging then failwith "unknown format" MethodBody.Abstract else @@ -3804,8 +3764,7 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int [] (* scopes fail for mscorlib scopes rootScope *) // REVIEW: look through sps to get ranges? Use GetRanges?? Change AbsIL?? (localPdbInfos, None, seqpoints) - with - | e -> + with e -> // "* Warning: PDB info for method "+nm+" could not be read and will be ignored: "+e.Message [], None, [] #endif @@ -3965,8 +3924,7 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int nextSectionBase <- sectionBase + sectionSize // Convert the linear code format to the nested code format - if logging then - dprintn "doing localPdbInfos2" + if logging then dprintn "doing localPdbInfos2" let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos @@ -3975,8 +3933,7 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int let code = buildILCode nm lab2pc instrs seh localPdbInfos2 - if logging then - dprintn "done checking code." + if logging then dprintn "done checking code." { IsZeroInit = initlocals @@ -4222,8 +4179,7 @@ let getPdbReader pdbDirPath fileName = | _ -> failwith ("Document with URL " + url + " not found in list of documents in the PDB file") Some(pdbr, docfun) - with - | e -> + with e -> dprintn ("* Warning: PDB file could not be read and will be ignored: " + e.Message) None #endif @@ -5111,8 +5067,8 @@ let stableFileHeuristicApplies fileName = not noStableFileHeuristic && try FileSystem.IsStableFileHeuristic fileName - with - | _ -> false + with _ -> + false let createByteFileChunk opts fileName chunk = // If we're trying to reduce memory usage then we are willing to go back and re-read the binary, so we can use @@ -5184,8 +5140,7 @@ let OpenILModuleReader fileName opts = ILModuleReaderCacheKey(fullPath, writeTime, opts.pdbDirPath.IsSome, opts.reduceMemoryUsage, opts.metadataOnly) key, true - with - | exn -> + with exn -> Debug.Assert( false, sprintf diff --git a/src/Compiler/AbstractIL/ilreflect.fs b/src/Compiler/AbstractIL/ilreflect.fs index 574075ea6b8..af089d2a8bc 100644 --- a/src/Compiler/AbstractIL/ilreflect.fs +++ b/src/Compiler/AbstractIL/ilreflect.fs @@ -646,8 +646,8 @@ let envUpdateCreatedTypeRef emEnv (tref: ILTypeRef) = try System.Runtime.Serialization.FormatterServices.GetUninitializedObject ty |> ignore - with - | _ -> () + with _ -> + () #endif { emEnv with emTypMap = Zmap.add tref (typT, typB, typeDef, Some ty) emEnv.emTypMap @@ -1101,11 +1101,7 @@ let queryableTypeGetMethod cenv emEnv parentT (mref: ILMethodRef) : MethodInfo = let stat = mref.CallingConv.IsStatic - let cconv = - (if stat then - BindingFlags.Static - else - BindingFlags.Instance) + let cconv = (if stat then BindingFlags.Static else BindingFlags.Instance) let methInfo = try @@ -1117,8 +1113,8 @@ let queryableTypeGetMethod cenv emEnv parentT (mref: ILMethodRef) : MethodInfo = (null: ParameterModifier[]) ) // This can fail if there is an ambiguity w.r.t. return type - with - | _ -> null + with _ -> + null if (isNotNull methInfo && equalTypes resT methInfo.ReturnType) then methInfo @@ -2568,8 +2564,7 @@ let createTypeRef (visited: Dictionary<_, _>, created: Dictionary<_, _>) emEnv t match emEnv.emTypMap.TryFind typeRef with | Some (_, tb, _, _) -> - if not (tb.IsCreated()) then - tb.CreateTypeAndLog() |> ignore + if not (tb.IsCreated()) then tb.CreateTypeAndLog() |> ignore tb.Assembly | None -> null) @@ -2595,8 +2590,7 @@ let createTypeRef (visited: Dictionary<_, _>, created: Dictionary<_, _>) emEnv t traverseTypeRef tref let rec buildTypeDefPass4 (visited, created) nesting emEnv (tdef: ILTypeDef) = - if verbose2 then - dprintf "buildTypeDefPass4 %s\n" tdef.Name + if verbose2 then dprintf "buildTypeDefPass4 %s\n" tdef.Name let tref = mkRefForNestedILTypeDef ILScopeRef.Local (nesting, tdef) createTypeRef (visited, created) emEnv tref @@ -2759,8 +2753,8 @@ let EmitDynamicAssemblyFragment try ignore (typB.InvokeMemberAndLog(methodName, BindingFlags.InvokeMethod ||| BindingFlags.Public ||| BindingFlags.Static, [||])) None - with - | :? TargetInvocationException as exn -> Some exn.InnerException + with :? TargetInvocationException as exn -> + Some exn.InnerException let emEnv, entryPts = envPopEntryPts emEnv let execs = List.map execEntryPtFun entryPts diff --git a/src/Compiler/AbstractIL/ilsign.fs b/src/Compiler/AbstractIL/ilsign.fs index b4eb67b8acb..6118383758e 100644 --- a/src/Compiler/AbstractIL/ilsign.fs +++ b/src/Compiler/AbstractIL/ilsign.fs @@ -221,28 +221,14 @@ let toCLRKeyBlob (rsaParameters: RSAParameters) (algId: int) : byte[] = bw.Write(int (modulusLength + BLOBHEADER_LENGTH)) // CLRHeader.KeyLength // Write out the BLOBHEADER - bw.Write( - byte ( - if isPrivate = true then - PRIVATEKEYBLOB - else - PUBLICKEYBLOB - ) - ) // BLOBHEADER.bType + bw.Write(byte (if isPrivate = true then PRIVATEKEYBLOB else PUBLICKEYBLOB)) // BLOBHEADER.bType bw.Write(byte BLOBHEADER_CURRENT_BVERSION) // BLOBHEADER.bVersion bw.Write(int16 0) // BLOBHEADER.wReserved bw.Write(int CALG_RSA_SIGN) // BLOBHEADER.aiKeyAlg // Write the RSAPubKey header - bw.Write( - int ( - if isPrivate then - RSA_PRIV_MAGIC - else - RSA_PUB_MAGIC - ) - ) // RSAPubKey.magic + bw.Write(int (if isPrivate then RSA_PRIV_MAGIC else RSA_PUB_MAGIC)) // RSAPubKey.magic bw.Write(int (modulusLength * 8)) // RSAPubKey.bitLen @@ -580,10 +566,7 @@ let legacySignerCloseKeyContainer kc = let legacySignerSignatureSize (pk: byte[]) = if runningOnMono then - if pk.Length > 32 then - pk.Length - 32 - else - 128 + if pk.Length > 32 then pk.Length - 32 else 128 else let mutable pSize = 0u let iclrSN = getICLRStrongName () @@ -704,8 +687,7 @@ type ILStrongNameSigner = let pkSignatureSize pk = try signerSignatureSize pk - with - | exn -> + with exn -> failwith ("A call to StrongNameSignatureSize failed (" + exn.Message + ")") 0x80 diff --git a/src/Compiler/AbstractIL/ilsupp.fs b/src/Compiler/AbstractIL/ilsupp.fs index 30050580dd5..1db894b1801 100644 --- a/src/Compiler/AbstractIL/ilsupp.fs +++ b/src/Compiler/AbstractIL/ilsupp.fs @@ -611,8 +611,7 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink let bNil = Bytes.zeroCreate 3 // Align remaining fields on DWORD (nb. poor bit twiddling code taken from ildasm's dres.cpp) - if (dwFiller &&& 0x1) <> 0 then - SaveChunk(bNil, 2) + if (dwFiller &&& 0x1) <> 0 then SaveChunk(bNil, 2) //---- Constant part of the header: DWORD, WORD, WORD, DWORD, DWORD SaveChunk(dwToBytes resHdr.DataVersion) @@ -628,8 +627,7 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink dwFiller <- dataEntry.Size &&& 0x3 - if dwFiller <> 0 then - SaveChunk(bNil, 4 - dwFiller) + if dwFiller <> 0 then SaveChunk(bNil, 4 - dwFiller) size @@ -1039,8 +1037,8 @@ let pdbClose (writer: PdbWriter) dllFilename pdbFilename = FileSystem.OpenFileForWriteShim(fileName, FileMode.Open, FileAccess.ReadWrite, FileShare.None) false - with - | _ -> true + with _ -> + true let mutable attempts = 0 @@ -1072,8 +1070,8 @@ let internal setCheckSum (url: string, writer: ISymUnmanagedDocumentWriter) = if (checkSum.Length = hashSizeOfMD5) then writer.SetCheckSum(guidSourceHashMD5, hashSizeOfMD5, checkSum) - with - | _ -> () + with _ -> + () let pdbDefineDocument (writer: PdbWriter) (url: string) = //3F5162F8-07C6-11D3-9053-00C04FA302A1 @@ -1204,8 +1202,8 @@ let pdbReadOpen (moduleName: string) (path: string) : PdbReader = ) { symReader = reader :?> ISymbolReader } - with - | _ -> { symReader = null } + with _ -> + { symReader = null } #else let symbolBinder = new System.Diagnostics.SymbolStore.SymBinder() diff --git a/src/Compiler/AbstractIL/ilwrite.fs b/src/Compiler/AbstractIL/ilwrite.fs index 61f02d8cc0d..8b8a13be429 100644 --- a/src/Compiler/AbstractIL/ilwrite.fs +++ b/src/Compiler/AbstractIL/ilwrite.fs @@ -768,17 +768,16 @@ and GetTypeDescAsTypeRefIdx cenv (scoref, enc, n) = GetTypeRefAsTypeRefIdx cenv (mkILNestedTyRef (scoref, enc, n)) and GetResolutionScopeAsElem cenv (scoref, enc) = - if isNil enc then + match List.tryFrontAndBack enc with + | None -> match scoref with | ILScopeRef.Local -> (rs_Module, 1) | ILScopeRef.Assembly aref -> (rs_AssemblyRef, GetAssemblyRefAsIdx cenv aref) | ILScopeRef.Module mref -> (rs_ModuleRef, GetModuleRefAsIdx cenv mref) | ILScopeRef.PrimaryAssembly -> (rs_AssemblyRef, GetAssemblyRefAsIdx cenv cenv.ilg.primaryAssemblyRef) - else - let enc2, n2 = List.frontAndBack enc + | Some (enc2, n2) -> (rs_TypeRef, GetTypeDescAsTypeRefIdx cenv (scoref, enc2, n2)) - let getTypeInfoAsTypeDefOrRefEncoded cenv (scoref, enc, nm) = if isScopeRefLocal scoref then let idx = GetIdxForTypeDef cenv (TdKey(enc, nm)) diff --git a/src/Compiler/AbstractIL/ilwritepdb.fs b/src/Compiler/AbstractIL/ilwritepdb.fs index df3ff04764c..c81cfc23ad3 100644 --- a/src/Compiler/AbstractIL/ilwritepdb.fs +++ b/src/Compiler/AbstractIL/ilwritepdb.fs @@ -130,10 +130,7 @@ module SequencePoint = else let c1 = compare sp1.Line sp2.Line - if c1 <> 0 then - c1 - else - compare sp1.Column sp2.Column + if c1 <> 0 then c1 else compare sp1.Column sp2.Column let orderByOffset sp1 sp2 = compare sp1.Offset sp2.Offset @@ -184,8 +181,8 @@ let checkSum (url: string) (checksumAlgorithm: HashAlgorithm) = let checkSum = alg.ComputeHash file Some(guid, checkSum) - with - | _ -> None + with _ -> + None //--------------------------------------------------------------------- // Portable PDB Writer @@ -377,11 +374,7 @@ type PortablePdbGenerator let s1, s2 = '/', '\\' - let separator = - if (count name s1) >= (count name s2) then - s1 - else - s2 + let separator = if (count name s1) >= (count name s2) then s1 else s2 let writer = BlobBuilder() writer.WriteByte(byte separator) @@ -445,12 +438,7 @@ type PortablePdbGenerator let documentIndex = let mutable index = Dictionary(docs.Length) - let docLength = - docs.Length - + if String.IsNullOrEmpty sourceLink then - 1 - else - 0 + let docLength = docs.Length + if String.IsNullOrEmpty sourceLink then 1 else 0 metadata.SetCapacity(TableIndex.Document, docLength) @@ -935,14 +923,14 @@ let writePdbInfo showTimes outfile pdbfile info cvChunk = try FileSystem.FileDeleteShim pdbfile - with - | _ -> () + with _ -> + () let pdbw = try pdbInitialize outfile pdbfile - with - | _ -> error (Error(FSComp.SR.ilwriteErrorCreatingPdb pdbfile, rangeCmdArgs)) + with _ -> + error (Error(FSComp.SR.ilwriteErrorCreatingPdb pdbfile, rangeCmdArgs)) match info.EntryPoint with | None -> () @@ -1020,16 +1008,14 @@ let writePdbInfo showTimes outfile pdbfile info cvChunk = | Some p -> sco.StartOffset <> p.StartOffset || sco.EndOffset <> p.EndOffset | None -> true - if nested then - pdbOpenScope pdbw sco.StartOffset + if nested then pdbOpenScope pdbw sco.StartOffset sco.Locals |> Array.iter (fun v -> pdbDefineLocalVariable pdbw v.Name v.Signature v.Index) sco.Children |> Array.iter (writePdbScope (if nested then Some sco else parent)) - if nested then - pdbCloseScope pdbw sco.EndOffset) + if nested then pdbCloseScope pdbw sco.EndOffset) match minfo.RootScope with | None -> () @@ -1119,16 +1105,16 @@ let writeMdbInfo fmdb f info = // Note, if we can't delete it code will fail later try FileSystem.FileDeleteShim fmdb - with - | _ -> () + with _ -> + () // Try loading the MDB symbol writer from an assembly available on Mono dynamically // Report an error if the assembly is not available. let wr = try createWriter f - with - | _ -> error (Error(FSComp.SR.ilwriteErrorCreatingMdb (), rangeCmdArgs)) + with _ -> + error (Error(FSComp.SR.ilwriteErrorCreatingMdb (), rangeCmdArgs)) // NOTE: MonoSymbolWriter doesn't need information about entrypoints, so 'info.EntryPoint' is unused here. // Write information about Documents. Returns '(SourceFileEntry*CompileUnitEntry)[]' diff --git a/src/Compiler/AbstractIL/ilx.fs b/src/Compiler/AbstractIL/ilx.fs index 5ef632ba2a5..6a7adab880b 100644 --- a/src/Compiler/AbstractIL/ilx.fs +++ b/src/Compiler/AbstractIL/ilx.fs @@ -10,10 +10,7 @@ let mkLowerName (nm: string) = // Use the lower case name of a field or constructor as the field/parameter name if it differs from the uppercase name let lowerName = String.uncapitalize nm - if lowerName = nm then - "_" + nm - else - lowerName + if lowerName = nm then "_" + nm else lowerName [] type IlxUnionCaseField(fd: ILFieldDef) = diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fs b/src/Compiler/Checking/AugmentWithHashCompare.fs index 8e2646ada99..f6faeb7bee7 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fs +++ b/src/Compiler/Checking/AugmentWithHashCompare.fs @@ -150,11 +150,9 @@ let mkDerefThis g m (thisv: Val) thise = else thise let mkCompareTestConjuncts g m exprs = - match exprs with - | [] -> mkZero g m - | [h] -> h - | l -> - let a, b = List.frontAndBack l + match List.tryFrontAndBack exprs with + | None -> mkZero g m + | Some (a,b) -> (a, b) ||> List.foldBack (fun e acc -> let nv, ne = mkCompGenLocal m "n" g.int_ty mkCompGenLet m nv e @@ -167,11 +165,9 @@ let mkCompareTestConjuncts g m exprs = acc))) let mkEqualsTestConjuncts g m exprs = - match exprs with - | [] -> mkOne g m - | [h] -> h - | l -> - let a, b = List.frontAndBack l + match List.tryFrontAndBack exprs with + | None -> mkOne g m + | Some (a,b) -> List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b let mkMinimalTy (g: TcGlobals) (tcref: TyconRef) = diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 0086fb44d2f..f18b0d1e7ce 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5816,16 +5816,17 @@ let ApplyAssemblyLevelAutoOpenAttributeToTcEnv g amap (ccu: CcuThunk) scopem env warning(Error(FSComp.SR.tcAttributeAutoOpenWasIgnored(p, ccu.AssemblyName), scopem)) [], env let p = splitNamespace p - if isNil p then warn() else - let h, t = List.frontAndBack p - let modref = mkNonLocalTyconRef (mkNonLocalEntityRef ccu (Array.ofList h)) t - match modref.TryDeref with - | ValueNone -> warn() - | ValueSome _ -> - let openTarget = SynOpenDeclTarget.ModuleOrNamespace([], scopem) - let openDecl = OpenDeclaration.Create (openTarget, [modref], [], scopem, false) - let envinner = OpenModuleOrNamespaceRefs TcResultsSink.NoSink g amap scopem root env [modref] openDecl - [openDecl], envinner + match List.tryFrontAndBack p with + | None -> warn() + | Some (h, t) -> + let modref = mkNonLocalTyconRef (mkNonLocalEntityRef ccu (Array.ofList h)) t + match modref.TryDeref with + | ValueNone -> warn() + | ValueSome _ -> + let openTarget = SynOpenDeclTarget.ModuleOrNamespace([], scopem) + let openDecl = OpenDeclaration.Create (openTarget, [modref], [], scopem, false) + let envinner = OpenModuleOrNamespaceRefs TcResultsSink.NoSink g amap scopem root env [modref] openDecl + [openDecl], envinner // Add the CCU and apply the "AutoOpen" attributes let AddCcuToTcEnv (g, amap, scopem, env, assemblyName, ccu, autoOpens, internalsVisibleToAttributes) = diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 0bb39d8d750..d79c19fe96a 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -8571,10 +8571,11 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = let CodegenAssembly cenv eenv mgbuf implFiles = - if not (isNil implFiles) then - let a, b = List.frontAndBack implFiles - let eenv = List.fold (GenImplFile cenv mgbuf None) eenv a - let eenv = GenImplFile cenv mgbuf cenv.options.mainMethodInfo eenv b + match List.tryFrontAndBack implFiles with + | None -> () + | Some (firstImplFiles, lastImplFile) -> + let eenv = List.fold (GenImplFile cenv mgbuf None) eenv firstImplFiles + let eenv = GenImplFile cenv mgbuf cenv.options.mainMethodInfo eenv lastImplFile // Some constructs generate residue types and bindings. Generate these now. They don't result in any // top-level initialization code. diff --git a/src/Compiler/Driver/BinaryResourceFormats.fs b/src/Compiler/Driver/BinaryResourceFormats.fs index 24ea75803d9..6c5c0ce3a66 100644 --- a/src/Compiler/Driver/BinaryResourceFormats.fs +++ b/src/Compiler/Driver/BinaryResourceFormats.fs @@ -8,37 +8,41 @@ open FSharp.Compiler.AbstractIL.IL // Helpers for generating binary blobs module BinaryGenerationUtilities = // Little-endian encoding of int32 - let b0 n = byte (n &&& 0xFF) - let b1 n = byte ((n >>> 8) &&& 0xFF) - let b2 n = byte ((n >>> 16) &&& 0xFF) - let b3 n = byte ((n >>> 24) &&& 0xFF) + let b0 n = byte (n &&& 0xFF) + let b1 n = byte ((n >>> 8) &&& 0xFF) + let b2 n = byte ((n >>> 16) &&& 0xFF) + let b3 n = byte ((n >>> 24) &&& 0xFF) let i16 (i: int32) = [| b0 i; b1 i |] let i32 (i: int32) = [| b0 i; b1 i; b2 i; b3 i |] // Emit the bytes and pad to a 32-bit alignment let Padded initialAlignment (v: byte[]) = - [| yield! v - for _ in 1..(4 - (initialAlignment + v.Length) % 4) % 4 do - yield 0x0uy |] + [| + yield! v + for _ in 1 .. (4 - (initialAlignment + v.Length) % 4) % 4 do + 0x0uy + |] // Generate nodes in a .res file format. These are then linked by Abstract IL using linkNativeResources module ResFileFormat = open BinaryGenerationUtilities - let ResFileNode(dwTypeID, dwNameID, wMemFlags, wLangID, data: byte[]) = - [| yield! i32 data.Length // DWORD ResHdr.dwDataSize - yield! i32 0x00000020 // dwHeaderSize - yield! i32 ((dwTypeID <<< 16) ||| 0x0000FFFF) // dwTypeID, sizeof(DWORD) - yield! i32 ((dwNameID <<< 16) ||| 0x0000FFFF) // dwNameID, sizeof(DWORD) - yield! i32 0x00000000 // DWORD dwDataVersion - yield! i16 wMemFlags // WORD wMemFlags - yield! i16 wLangID // WORD wLangID - yield! i32 0x00000000 // DWORD dwVersion - yield! i32 0x00000000 // DWORD dwCharacteristics - yield! Padded 0 data |] + let ResFileNode (dwTypeID, dwNameID, wMemFlags, wLangID, data: byte[]) = + [| + yield! i32 data.Length // DWORD ResHdr.dwDataSize + yield! i32 0x00000020 // dwHeaderSize + yield! i32 ((dwTypeID <<< 16) ||| 0x0000FFFF) // dwTypeID, sizeof(DWORD) + yield! i32 ((dwNameID <<< 16) ||| 0x0000FFFF) // dwNameID, sizeof(DWORD) + yield! i32 0x00000000 // DWORD dwDataVersion + yield! i16 wMemFlags // WORD wMemFlags + yield! i16 wLangID // WORD wLangID + yield! i32 0x00000000 // DWORD dwVersion + yield! i32 0x00000000 // DWORD dwCharacteristics + yield! Padded 0 data + |] - let ResFileHeader() = ResFileNode(0x0, 0x0, 0x0, 0x0, [| |]) + let ResFileHeader () = ResFileNode(0x0, 0x0, 0x0, 0x0, [||]) // Generate the VS_VERSION_INFO structure held in a Win32 Version Resource in a PE file // @@ -46,172 +50,191 @@ module ResFileFormat = module VersionResourceFormat = open BinaryGenerationUtilities - let VersionInfoNode(data: byte[]) = - [| yield! i16 (data.Length + 2) // wLength : int16 // Specifies the length, in bytes, of the VS_VERSION_INFO structure. - yield! data |] + let VersionInfoNode (data: byte[]) = + [| + yield! i16 (data.Length + 2) // wLength : int16 // Specifies the length, in bytes, of the VS_VERSION_INFO structure. + yield! data + |] - let VersionInfoElement(wType, szKey, valueOpt: byte[] option, children: byte[][], isString) = + let VersionInfoElement (wType, szKey, valueOpt: byte[] option, children: byte[][], isString) = // for String structs, wValueLength represents the word count, not the byte count - let wValueLength = (match valueOpt with None -> 0 | Some value -> (if isString then value.Length / 2 else value.Length)) + let wValueLength = + (match valueOpt with + | None -> 0 + | Some value -> (if isString then value.Length / 2 else value.Length)) + VersionInfoNode - [| yield! i16 wValueLength // wValueLength: int16. Specifies the length, in words, of the Value member. - yield! i16 wType // wType : int16 Specifies the type of data in the version resource. - yield! Padded 2 szKey - match valueOpt with - | None -> yield! [] - | Some value -> yield! Padded 0 value - for child in children do - yield! child |] - - let Version(version: ILVersionInfo) = + [| + yield! i16 wValueLength // wValueLength: int16. Specifies the length, in words, of the Value member. + yield! i16 wType // wType : int16 Specifies the type of data in the version resource. + yield! Padded 2 szKey + match valueOpt with + | None -> yield! [] + | Some value -> yield! Padded 0 value + for child in children do + yield! child + |] + + let Version (version: ILVersionInfo) = [| // DWORD dwFileVersionMS - // Specifies the most significant 32 bits of the file's binary - // version number. This member is used with dwFileVersionLS to form a 64-bit value used - // for numeric comparisons. - yield! i32 (int32 version.Major <<< 16 ||| int32 version.Minor) - - // DWORD dwFileVersionLS - // Specifies the least significant 32 bits of the file's binary - // version number. This member is used with dwFileVersionMS to form a 64-bit value used - // for numeric comparisons. - yield! i32 (int32 version.Build <<< 16 ||| int32 version.Revision) + // Specifies the most significant 32 bits of the file's binary + // version number. This member is used with dwFileVersionLS to form a 64-bit value used + // for numeric comparisons. + yield! i32 (int32 version.Major <<< 16 ||| int32 version.Minor) + + // DWORD dwFileVersionLS + // Specifies the least significant 32 bits of the file's binary + // version number. This member is used with dwFileVersionMS to form a 64-bit value used + // for numeric comparisons. + yield! i32 (int32 version.Build <<< 16 ||| int32 version.Revision) |] - let String(string, value) = + let String (string, value) = let wType = 0x1 // Specifies the type of data in the version resource. let szKey = Bytes.stringAsUnicodeNullTerminated string - VersionInfoElement(wType, szKey, Some (Bytes.stringAsUnicodeNullTerminated value), [| |], true) + VersionInfoElement(wType, szKey, Some(Bytes.stringAsUnicodeNullTerminated value), [||], true) - let StringTable(language, strings) = + let StringTable (language, strings) = let wType = 0x1 // Specifies the type of data in the version resource. let szKey = Bytes.stringAsUnicodeNullTerminated language - // Specifies an 8-digit hexadecimal number stored as a Unicode string. + // Specifies an 8-digit hexadecimal number stored as a Unicode string. let children = - [| for string in strings do - yield String string |] + [| + for string in strings do + String string + |] + VersionInfoElement(wType, szKey, None, children, false) - let StringFileInfo(stringTables: #seq >) = + let StringFileInfo (stringTables: #seq>) = let wType = 0x1 // Specifies the type of data in the version resource. let szKey = Bytes.stringAsUnicodeNullTerminated "StringFileInfo" // Contains the Unicode string StringFileInfo // Contains an array of one or more StringTable structures. let children = - [| for stringTable in stringTables do - yield StringTable stringTable |] + [| + for stringTable in stringTables do + StringTable stringTable + |] + VersionInfoElement(wType, szKey, None, children, false) - let VarFileInfo(vars: #seq) = + let VarFileInfo (vars: #seq) = let wType = 0x1 // Specifies the type of data in the version resource. let szKey = Bytes.stringAsUnicodeNullTerminated "VarFileInfo" // Contains the Unicode string StringFileInfo // Contains an array of one or more StringTable structures. let children = - [| for lang, codePage in vars do - let szKey = Bytes.stringAsUnicodeNullTerminated "Translation" - yield VersionInfoElement(0x0, szKey, Some([| yield! i16 lang - yield! i16 codePage |]), [| |], false) |] + [| + for lang, codePage in vars do + let szKey = Bytes.stringAsUnicodeNullTerminated "Translation" + VersionInfoElement(0x0, szKey, Some([| yield! i16 lang; yield! i16 codePage |]), [||], false) + |] + VersionInfoElement(wType, szKey, None, children, false) - let VS_FIXEDFILEINFO(fileVersion: ILVersionInfo, - productVersion: ILVersionInfo, - dwFileFlagsMask, - dwFileFlags, dwFileOS, - dwFileType, dwFileSubtype, - lwFileDate: int64) = + let VS_FIXEDFILEINFO + ( + fileVersion: ILVersionInfo, + productVersion: ILVersionInfo, + dwFileFlagsMask, + dwFileFlags, + dwFileOS, + dwFileType, + dwFileSubtype, + lwFileDate: int64 + ) = let dwStrucVersion = 0x00010000 + [| // DWORD dwSignature // Contains the value 0xFEEFO4BD. - yield! i32 0xFEEF04BD - - // DWORD dwStrucVersion // Specifies the binary version number of this structure. - yield! i32 dwStrucVersion - - // DWORD dwFileVersionMS, dwFileVersionLS // Specifies the most/least significant 32 bits of the file's binary version number. - yield! Version fileVersion - - // DWORD dwProductVersionMS, dwProductVersionLS // Specifies the most/least significant 32 bits of the file's binary version number. - yield! Version productVersion - - // DWORD dwFileFlagsMask // Contains a bitmask that specifies the valid bits in dwFileFlags. - yield! i32 dwFileFlagsMask - - // DWORD dwFileFlags // Contains a bitmask that specifies the Boolean attributes of the file. - yield! i32 dwFileFlags - // VS_FF_DEBUG 0x1L The file contains debugging information or is compiled with debugging features enabled. - // VS_FF_INFOINFERRED The file's version structure was created dynamically; therefore, some of the members - // in this structure may be empty or incorrect. This flag should never be set in a file's - // VS_VERSION_INFO data. - // VS_FF_PATCHED The file has been modified and is not identical to the original shipping file of - // the same version number. - // VS_FF_PRERELEASE The file is a development version, not a commercially released product. - // VS_FF_PRIVATEBUILD The file was not built using standard release procedures. If this flag is - // set, the StringFileInfo structure should contain a PrivateBuild entry. - // VS_FF_SPECIALBUILD The file was built by the original company using standard release procedures - // but is a variation of the normal file of the same version number. If this - // flag is set, the StringFileInfo structure should contain a SpecialBuild entry. - - //Specifies the operating system for which this file was designed. This member can be one of the following values: Flag - yield! i32 dwFileOS - //VOS_DOS 0x0001L The file was designed for MS-DOS. - //VOS_NT 0x0004L The file was designed for Windows NT. - //VOS__WINDOWS16 The file was designed for 16-bit Windows. - //VOS__WINDOWS32 The file was designed for the Win32 API. - //VOS_OS216 0x00020000L The file was designed for 16-bit OS/2. - //VOS_OS232 0x00030000L The file was designed for 32-bit OS/2. - //VOS__PM16 The file was designed for 16-bit Presentation Manager. - //VOS__PM32 The file was designed for 32-bit Presentation Manager. - //VOS_UNKNOWN The operating system for which the file was designed is unknown to Windows. - - // Specifies the general type of file. This member can be one of the following values: - yield! i32 dwFileType - - //VFT_UNKNOWN The file type is unknown to Windows. - //VFT_APP The file contains an application. - //VFT_DLL The file contains a dynamic-link library (DLL). - //VFT_DRV The file contains a device driver. If dwFileType is VFT_DRV, dwFileSubtype contains a more specific description of the driver. - //VFT_FONT The file contains a font. If dwFileType is VFT_FONT, dwFileSubtype contains a more specific description of the font file. - //VFT_VXD The file contains a virtual device. - //VFT_STATIC_LIB The file contains a static-link library. - - // Specifies the function of the file. The possible values depend on the value of - // dwFileType. For all values of dwFileType not described in the following list, - // dwFileSubtype is zero. If dwFileType is VFT_DRV, dwFileSubtype can be one of the following values: - yield! i32 dwFileSubtype - //VFT2_UNKNOWN The driver type is unknown by Windows. - //VFT2_DRV_COMM The file contains a communications driver. - //VFT2_DRV_PRINTER The file contains a printer driver. - //VFT2_DRV_KEYBOARD The file contains a keyboard driver. - //VFT2_DRV_LANGUAGE The file contains a language driver. - //VFT2_DRV_DISPLAY The file contains a display driver. - //VFT2_DRV_MOUSE The file contains a mouse driver. - //VFT2_DRV_NETWORK The file contains a network driver. - //VFT2_DRV_SYSTEM The file contains a system driver. - //VFT2_DRV_INSTALLABLE The file contains an installable driver. - //VFT2_DRV_SOUND The file contains a sound driver. - // - //If dwFileType is VFT_FONT, dwFileSubtype can be one of the following values: - // - //VFT2_UNKNOWN The font type is unknown by Windows. - //VFT2_FONT_RASTER The file contains a raster font. - //VFT2_FONT_VECTOR The file contains a vector font. - //VFT2_FONT_TRUETYPE The file contains a TrueType font. - // - //If dwFileType is VFT_VXD, dwFileSubtype contains the virtual device identifier included in the virtual device control block. - - // Specifies the most significant 32 bits of the file's 64-bit binary creation date and time stamp. - yield! i32 (int32 (lwFileDate >>> 32)) - - //Specifies the least significant 32 bits of the file's 64-bit binary creation date and time stamp. - yield! i32 (int32 lwFileDate) - |] - - let VS_VERSION_INFO(fixedFileInfo, stringFileInfo, varFileInfo) = + yield! i32 0xFEEF04BD + + // DWORD dwStrucVersion // Specifies the binary version number of this structure. + yield! i32 dwStrucVersion + + // DWORD dwFileVersionMS, dwFileVersionLS // Specifies the most/least significant 32 bits of the file's binary version number. + yield! Version fileVersion + + // DWORD dwProductVersionMS, dwProductVersionLS // Specifies the most/least significant 32 bits of the file's binary version number. + yield! Version productVersion + + // DWORD dwFileFlagsMask // Contains a bitmask that specifies the valid bits in dwFileFlags. + yield! i32 dwFileFlagsMask + + // DWORD dwFileFlags // Contains a bitmask that specifies the Boolean attributes of the file. + yield! i32 dwFileFlags + // VS_FF_DEBUG 0x1L The file contains debugging information or is compiled with debugging features enabled. + // VS_FF_INFOINFERRED The file's version structure was created dynamically; therefore, some of the members + // in this structure may be empty or incorrect. This flag should never be set in a file's + // VS_VERSION_INFO data. + // VS_FF_PATCHED The file has been modified and is not identical to the original shipping file of + // the same version number. + // VS_FF_PRERELEASE The file is a development version, not a commercially released product. + // VS_FF_PRIVATEBUILD The file was not built using standard release procedures. If this flag is + // set, the StringFileInfo structure should contain a PrivateBuild entry. + // VS_FF_SPECIALBUILD The file was built by the original company using standard release procedures + // but is a variation of the normal file of the same version number. If this + // flag is set, the StringFileInfo structure should contain a SpecialBuild entry. + + //Specifies the operating system for which this file was designed. This member can be one of the following values: Flag + yield! i32 dwFileOS + //VOS_DOS 0x0001L The file was designed for MS-DOS. + //VOS_NT 0x0004L The file was designed for Windows NT. + //VOS__WINDOWS16 The file was designed for 16-bit Windows. + //VOS__WINDOWS32 The file was designed for the Win32 API. + //VOS_OS216 0x00020000L The file was designed for 16-bit OS/2. + //VOS_OS232 0x00030000L The file was designed for 32-bit OS/2. + //VOS__PM16 The file was designed for 16-bit Presentation Manager. + //VOS__PM32 The file was designed for 32-bit Presentation Manager. + //VOS_UNKNOWN The operating system for which the file was designed is unknown to Windows. + + // Specifies the general type of file. This member can be one of the following values: + yield! i32 dwFileType + + //VFT_UNKNOWN The file type is unknown to Windows. + //VFT_APP The file contains an application. + //VFT_DLL The file contains a dynamic-link library (DLL). + //VFT_DRV The file contains a device driver. If dwFileType is VFT_DRV, dwFileSubtype contains a more specific description of the driver. + //VFT_FONT The file contains a font. If dwFileType is VFT_FONT, dwFileSubtype contains a more specific description of the font file. + //VFT_VXD The file contains a virtual device. + //VFT_STATIC_LIB The file contains a static-link library. + + // Specifies the function of the file. The possible values depend on the value of + // dwFileType. For all values of dwFileType not described in the following list, + // dwFileSubtype is zero. If dwFileType is VFT_DRV, dwFileSubtype can be one of the following values: + yield! i32 dwFileSubtype + //VFT2_UNKNOWN The driver type is unknown by Windows. + //VFT2_DRV_COMM The file contains a communications driver. + //VFT2_DRV_PRINTER The file contains a printer driver. + //VFT2_DRV_KEYBOARD The file contains a keyboard driver. + //VFT2_DRV_LANGUAGE The file contains a language driver. + //VFT2_DRV_DISPLAY The file contains a display driver. + //VFT2_DRV_MOUSE The file contains a mouse driver. + //VFT2_DRV_NETWORK The file contains a network driver. + //VFT2_DRV_SYSTEM The file contains a system driver. + //VFT2_DRV_INSTALLABLE The file contains an installable driver. + //VFT2_DRV_SOUND The file contains a sound driver. + // + //If dwFileType is VFT_FONT, dwFileSubtype can be one of the following values: + // + //VFT2_UNKNOWN The font type is unknown by Windows. + //VFT2_FONT_RASTER The file contains a raster font. + //VFT2_FONT_VECTOR The file contains a vector font. + //VFT2_FONT_TRUETYPE The file contains a TrueType font. + // + //If dwFileType is VFT_VXD, dwFileSubtype contains the virtual device identifier included in the virtual device control block. + + // Specifies the most significant 32 bits of the file's 64-bit binary creation date and time stamp. + yield! i32 (int32 (lwFileDate >>> 32)) + + //Specifies the least significant 32 bits of the file's 64-bit binary creation date and time stamp. + yield! i32 (int32 lwFileDate) + |] + + let VS_VERSION_INFO (fixedFileInfo, stringFileInfo, varFileInfo) = let wType = 0x0 let szKey = Bytes.stringAsUnicodeNullTerminated "VS_VERSION_INFO" // Contains the Unicode string VS_VERSION_INFO let value = VS_FIXEDFILEINFO fixedFileInfo - let children = - [| yield StringFileInfo stringFileInfo - yield VarFileInfo varFileInfo - |] + let children = [| StringFileInfo stringFileInfo; VarFileInfo varFileInfo |] VersionInfoElement(wType, szKey, Some value, children, false) let VS_VERSION_INFO_RESOURCE data = @@ -223,7 +246,7 @@ module VersionResourceFormat = module ManifestResourceFormat = - let VS_MANIFEST_RESOURCE(data, isLibrary) = + let VS_MANIFEST_RESOURCE (data, isLibrary) = let dwTypeID = 0x0018 let dwNameID = if isLibrary then 0x2 else 0x1 let wMemFlags = 0x0 diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 7027e682d8e..256d06456f3 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -30,23 +30,22 @@ open FSharp.Compiler.BuildGraph open FSharp.Core.CompilerServices #endif -let (++) x s = x @ [s] +let (++) x s = x @ [ s ] //---------------------------------------------------------------------------- // Some Globals //-------------------------------------------------------------------------- -let FSharpSigFileSuffixes = [".mli";".fsi"] +let FSharpSigFileSuffixes = [ ".mli"; ".fsi" ] -let mlCompatSuffixes = [".mli";".ml"] +let FSharpMLCompatFileSuffixes = [ ".mli"; ".ml" ] -let FSharpImplFileSuffixes = [".ml";".fs";".fsscript";".fsx"] +let FSharpImplFileSuffixes = [ ".ml"; ".fs"; ".fsscript"; ".fsx" ] -let FSharpScriptFileSuffixes = [".fsscript";".fsx"] +let FSharpScriptFileSuffixes = [ ".fsscript"; ".fsx" ] -let doNotRequireNamespaceOrModuleSuffixes = [".mli";".ml"] @ FSharpScriptFileSuffixes - -let FSharpIndentationAwareSyntaxFileSuffixes = [ ".fs";".fsscript";".fsx";".fsi" ] +let FSharpIndentationAwareSyntaxFileSuffixes = + [ ".fs"; ".fsscript"; ".fsx"; ".fsi" ] //-------------------------------------------------------------------------- // General file name resolver @@ -57,52 +56,62 @@ exception FileNameNotResolved of searchedLocations: string * fileName: string * exception LoadedSourceNotFoundIgnoring of fileName: string * range: range /// Will return None if the fileName is not found. -let TryResolveFileUsingPaths(paths, m, fileName) = +let TryResolveFileUsingPaths (paths, m, fileName) = let () = - try FileSystem.IsPathRootedShim fileName |> ignore - with :? ArgumentException as e -> error(Error(FSComp.SR.buildProblemWithFilename(fileName, e.Message), m)) + try + FileSystem.IsPathRootedShim fileName |> ignore + with :? ArgumentException as e -> + error (Error(FSComp.SR.buildProblemWithFilename (fileName, e.Message), m)) + if FileSystem.IsPathRootedShim fileName then if FileSystem.FileExistsShim fileName then Some fileName else None else - let res = paths |> Seq.tryPick (fun path -> - let n = Path.Combine(path, fileName) - if FileSystem.FileExistsShim n then Some n - else None) + let res = + paths + |> Seq.tryPick (fun path -> + let n = Path.Combine(path, fileName) + if FileSystem.FileExistsShim n then Some n else None) + res /// Will raise FileNameNotResolved if the fileName was not found -let ResolveFileUsingPaths(paths, m, fileName) = +let ResolveFileUsingPaths (paths, m, fileName) = match TryResolveFileUsingPaths(paths, m, fileName) with | Some res -> res | None -> let searchMessage = String.concat "\n " paths raise (FileNameNotResolved(fileName, searchMessage, m)) -let GetWarningNumber(m, warningNumber: string) = +let GetWarningNumber (m, warningNumber: string) = try // Okay so ... // #pragma strips FS of the #pragma "FS0004" and validates the warning number // therefore if we have warning id that starts with a numeric digit we convert it to Some (int32) // anything else is ignored None - if Char.IsDigit(warningNumber[0]) then Some (int32 warningNumber) - elif warningNumber.StartsWithOrdinal("FS") = true then raise (ArgumentException()) - else None + if Char.IsDigit(warningNumber[0]) then + Some(int32 warningNumber) + elif warningNumber.StartsWithOrdinal("FS") = true then + raise (ArgumentException()) + else + None with _ -> - warning(Error(FSComp.SR.buildInvalidWarningNumber warningNumber, m)) + warning (Error(FSComp.SR.buildInvalidWarningNumber warningNumber, m)) None let ComputeMakePathAbsolute implicitIncludeDir (path: string) = try // remove any quotation marks from the path first let path = path.Replace("\"", "") - if not (FileSystem.IsPathRootedShim path) - then Path.Combine (implicitIncludeDir, path) - else path - with - :? ArgumentException -> path + + if not (FileSystem.IsPathRootedShim path) then + Path.Combine(implicitIncludeDir, path) + else + path + with :? ArgumentException -> + path //---------------------------------------------------------------------------- // Configuration @@ -114,38 +123,56 @@ type CompilerTarget = | ConsoleExe | Dll | Module - member x.IsExe = (match x with ConsoleExe | WinExe -> true | _ -> false) + + member x.IsExe = + (match x with + | ConsoleExe + | WinExe -> true + | _ -> false) [] -type ResolveAssemblyReferenceMode = Speculative | ReportErrors +type ResolveAssemblyReferenceMode = + | Speculative + | ReportErrors [] -type CopyFSharpCoreFlag = Yes | No +type CopyFSharpCoreFlag = + | Yes + | No /// Represents the file or string used for the --version flag type VersionFlag = | VersionString of string | VersionFile of string | VersionNone + member x.GetVersionInfo implicitIncludeDir = let vstr = x.GetVersionString implicitIncludeDir + try parseILVersion vstr - with _ -> errorR(Error(FSComp.SR.buildInvalidVersionString vstr, rangeStartup)); parseILVersion "0.0.0.0" + with _ -> + errorR (Error(FSComp.SR.buildInvalidVersionString vstr, rangeStartup)) + parseILVersion "0.0.0.0" member x.GetVersionString implicitIncludeDir = - match x with - | VersionString s -> s - | VersionFile s -> - let s = if FileSystem.IsPathRootedShim s then s else Path.Combine(implicitIncludeDir, s) - if not(FileSystem.FileExistsShim s) then - errorR(Error(FSComp.SR.buildInvalidVersionFile s, rangeStartup)); "0.0.0.0" - else - use fs = FileSystem.OpenFileForReadShim(s) - use is = new StreamReader(fs) - is.ReadLine() - | VersionNone -> "0.0.0.0" + match x with + | VersionString s -> s + | VersionFile s -> + let s = + if FileSystem.IsPathRootedShim s then + s + else + Path.Combine(implicitIncludeDir, s) + if not (FileSystem.FileExistsShim s) then + errorR (Error(FSComp.SR.buildInvalidVersionFile s, rangeStartup)) + "0.0.0.0" + else + use fs = FileSystem.OpenFileForReadShim(s) + use is = new StreamReader(fs) + is.ReadLine() + | VersionNone -> "0.0.0.0" /// Represents a reference to an assembly. May be backed by a real assembly on disk, or a cross-project /// reference backed by information generated by the the compiler service. @@ -164,7 +191,8 @@ type IRawFSharpAssemblyData = abstract GetRawFSharpSignatureData: range * ilShortAssemName: string * fileName: string -> (string * (unit -> ReadOnlyByteMemory)) list /// The raw F# optimization data in the assembly, if any - abstract GetRawFSharpOptimizationData: range * ilShortAssemName: string * fileName: string -> (string * (unit -> ReadOnlyByteMemory)) list + abstract GetRawFSharpOptimizationData: + range * ilShortAssemName: string * fileName: string -> (string * (unit -> ReadOnlyByteMemory)) list /// The table of type forwarders in the assembly abstract GetRawTypeForwarders: unit -> ILExportedTypesAndForwarders @@ -185,29 +213,36 @@ type IRawFSharpAssemblyData = /// Cache of time stamps as we traverse a project description type TimeStampCache(defaultTimeStamp: DateTime) = let files = ConcurrentDictionary() - let projects = ConcurrentDictionary(HashIdentity.Reference) + + let projects = + ConcurrentDictionary(HashIdentity.Reference) member _.GetFileTimeStamp fileName = let ok, v = files.TryGetValue fileName - if ok then v else - let v = - try - FileSystem.GetLastWriteTimeShim fileName - with - | :? FileNotFoundException -> - defaultTimeStamp - files[fileName] <- v - v - member cache.GetProjectReferenceTimeStamp (projectReference: IProjectReference) = + if ok then + v + else + let v = + try + FileSystem.GetLastWriteTimeShim fileName + with :? FileNotFoundException -> + defaultTimeStamp + + files[fileName] <- v + v + + member cache.GetProjectReferenceTimeStamp(projectReference: IProjectReference) = let ok, v = projects.TryGetValue projectReference - if ok then v else - let v = defaultArg (projectReference.TryGetLogicalTimeStamp cache) defaultTimeStamp - projects[projectReference] <- v - v -and [] - ProjectAssemblyDataResult = + if ok then + v + else + let v = defaultArg (projectReference.TryGetLogicalTimeStamp cache) defaultTimeStamp + projects[projectReference] <- v + v + +and [] ProjectAssemblyDataResult = | Available of IRawFSharpAssemblyData | Unavailable of useOnDiskInstead: bool @@ -229,22 +264,24 @@ and IProjectReference = abstract TryGetLogicalTimeStamp: cache: TimeStampCache -> DateTime option type AssemblyReference = - | AssemblyReference of range * string * IProjectReference option + | AssemblyReference of range: range * text: string * projectReference: IProjectReference option - member x.Range = (let (AssemblyReference(m, _, _)) = x in m) + member x.Range = (let (AssemblyReference (m, _, _)) = x in m) - member x.Text = (let (AssemblyReference(_, text, _)) = x in text) + member x.Text = (let (AssemblyReference (_, text, _)) = x in text) - member x.ProjectReference = (let (AssemblyReference(_, _, contents)) = x in contents) + member x.ProjectReference = (let (AssemblyReference (_, _, contents)) = x in contents) member x.SimpleAssemblyNameIs name = - (String.Compare(FileSystemUtils.fileNameWithoutExtensionWithValidate false x.Text, name, StringComparison.OrdinalIgnoreCase) = 0) || - not (x.Text.Contains "/") && - not (x.Text.Contains "\\") && - not (x.Text.EndsWith(".dll", StringComparison.InvariantCultureIgnoreCase)) && - not (x.Text.EndsWith(".exe", StringComparison.InvariantCultureIgnoreCase)) && - (try let aname = System.Reflection.AssemblyName x.Text in aname.Name = name - with _ -> false) + (String.Compare(FileSystemUtils.fileNameWithoutExtensionWithValidate false x.Text, name, StringComparison.OrdinalIgnoreCase) = 0) + || not (x.Text.Contains "/") + && not (x.Text.Contains "\\") + && not (x.Text.EndsWith(".dll", StringComparison.InvariantCultureIgnoreCase)) + && not (x.Text.EndsWith(".exe", StringComparison.InvariantCultureIgnoreCase)) + && (try + let aname = System.Reflection.AssemblyName x.Text in aname.Name = name + with _ -> + false) override x.ToString() = sprintf "AssemblyReference(%s)" x.Text @@ -254,15 +291,17 @@ type ResolvedExtensionReference = ResolvedExtensionReference of string * Assembl #endif type ImportedAssembly = - { ILScopeRef: ILScopeRef - FSharpViewOfMetadata: CcuThunk - AssemblyAutoOpenAttributes: string list - AssemblyInternalsVisibleToAttributes: string list + { + ILScopeRef: ILScopeRef + FSharpViewOfMetadata: CcuThunk + AssemblyAutoOpenAttributes: string list + AssemblyInternalsVisibleToAttributes: string list #if !NO_TYPEPROVIDERS - IsProviderGenerated: bool - mutable TypeProviders: Tainted list + IsProviderGenerated: bool + mutable TypeProviders: Tainted list #endif - FSharpOptimizationData: Microsoft.FSharp.Control.Lazy> } + FSharpOptimizationData: Microsoft.FSharp.Control.Lazy> + } type AvailableImportedAssembly = | ResolvedImportedAssembly of ImportedAssembly @@ -286,50 +325,61 @@ type TokenizeOption = | Unfiltered type PackageManagerLine = - { Directive: Directive - LineStatus: LStatus - Line: string - Range: range } - - static member AddLineWithKey (packageKey: string) (directive:Directive) (line: string) (m: range) (packageManagerLines: Map): Map = + { + Directive: Directive + LineStatus: LStatus + Line: string + Range: range + } + + static member AddLineWithKey + (packageKey: string) + (directive: Directive) + (line: string) + (m: range) + (packageManagerLines: Map) + : Map = let path = PackageManagerLine.StripDependencyManagerKey packageKey line - let map = - let mutable found = false - let result = - packageManagerLines - |> Map.map(fun key lines -> - if key = packageKey then - found <- true - lines |> List.append [{Directive=directive; LineStatus=LStatus.Unprocessed; Line=path; Range=m}] - else - lines) - if found then - result - else - result.Add(packageKey, [{Directive=directive; LineStatus=LStatus.Unprocessed; Line=path; Range=m}]) - map - - static member RemoveUnprocessedLines (packageKey: string) (packageManagerLines: Map): Map = - let map = - packageManagerLines - |> Map.map(fun key lines -> - if key = packageKey then - lines |> List.filter(fun line -> line.LineStatus=LStatus.Processed) - else - lines) - map - - static member SetLinesAsProcessed (packageKey:string) (packageManagerLines: Map): Map = - let map = - packageManagerLines - |> Map.map(fun key lines -> - if key = packageKey then - lines |> List.map(fun line -> {line with LineStatus = LStatus.Processed;}) - else - lines) - map - static member StripDependencyManagerKey (packageKey: string) (line: string): string = + let newLine = + { + Directive = directive + LineStatus = LStatus.Unprocessed + Line = path + Range = m + } + + let oldLines = MultiMap.find packageKey packageManagerLines + let newLines = oldLines @ [ newLine ] + packageManagerLines.Add(packageKey, newLines) + + static member RemoveUnprocessedLines + (packageKey: string) + (packageManagerLines: Map) + : Map = + let oldLines = MultiMap.find packageKey packageManagerLines + + let newLines = + oldLines |> List.filter (fun line -> line.LineStatus = LStatus.Processed) + + packageManagerLines.Add(packageKey, newLines) + + static member SetLinesAsProcessed + (packageKey: string) + (packageManagerLines: Map) + : Map = + let oldLines = MultiMap.find packageKey packageManagerLines + + let newLines = + oldLines + |> List.map (fun line -> + { line with + LineStatus = LStatus.Processed + }) + + packageManagerLines.Add(packageKey, newLines) + + static member StripDependencyManagerKey (packageKey: string) (line: string) : string = line.Substring(packageKey.Length + 1).Trim() [] @@ -341,186 +391,185 @@ type MetadataAssemblyGeneration = [] type TcConfigBuilder = { - mutable primaryAssembly: PrimaryAssembly - mutable noFeedback: bool - mutable stackReserveSize: int32 option - mutable implicitIncludeDir: string (* normally "." *) - mutable openDebugInformationForLaterStaticLinking: bool (* only for --standalone *) - defaultFSharpBinariesDir: string - mutable compilingFSharpCore: bool - mutable useIncrementalBuilder: bool - mutable includes: string list - mutable implicitOpens: string list - mutable useFsiAuxLib: bool - mutable implicitlyReferenceDotNetAssemblies: bool - mutable resolutionEnvironment: LegacyResolutionEnvironment - mutable implicitlyResolveAssemblies: bool - mutable indentationAwareSyntax: bool option - mutable conditionalDefines: string list - mutable loadedSources: (range * string * string) list - mutable compilerToolPaths: string list - mutable referencedDLLs: AssemblyReference list - mutable packageManagerLines: Map - mutable projectReferences: IProjectReference list - mutable knownUnresolvedReferences: UnresolvedAssemblyReference list - reduceMemoryUsage: ReduceMemoryFlag - mutable subsystemVersion: int * int - mutable useHighEntropyVA: bool - mutable inputCodePage: int option - mutable embedResources: string list - mutable diagnosticsOptions: FSharpDiagnosticOptions - mutable mlCompatibility: bool - mutable checkOverflow: bool - mutable showReferenceResolutions: bool - mutable outputDir : string option - mutable outputFile: string option - mutable platform: ILPlatform option - mutable prefer32Bit: bool - mutable useSimpleResolution: bool - mutable target: CompilerTarget - mutable debuginfo: bool - mutable testFlagEmitFeeFeeAs100001: bool - mutable dumpDebugInfo: bool - mutable debugSymbolFile: string option - (* Backend configuration *) - mutable typeCheckOnly: bool - mutable parseOnly: bool - mutable importAllReferencesOnly: bool - mutable simulateException: string option - mutable printAst: bool - mutable tokenize: TokenizeOption - mutable testInteractionParser: bool - mutable reportNumDecls: bool - mutable printSignature: bool - mutable printSignatureFile: string - mutable printAllSignatureFiles: bool - mutable xmlDocOutputFile: string option - mutable stats: bool - mutable generateFilterBlocks: bool (* don't generate filter blocks due to bugs on Mono *) - - mutable signer: string option - mutable container: string option - - mutable delaysign: bool - mutable publicsign: bool - mutable version: VersionFlag - mutable metadataVersion: string option - mutable standalone: bool - mutable extraStaticLinkRoots: string list - mutable noSignatureData: bool - mutable onlyEssentialOptimizationData: bool - mutable useOptimizationDataFile: bool - mutable jitTracking: bool - mutable portablePDB: bool - mutable embeddedPDB: bool - mutable embedAllSource: bool - mutable embedSourceList: string list - mutable sourceLink: string - - mutable ignoreSymbolStoreSequencePoints: bool - mutable internConstantStrings: bool - mutable extraOptimizationIterations: int - - mutable win32icon: string - mutable win32res: string - mutable win32manifest: string - mutable includewin32manifest: bool - mutable linkResources: string list - - mutable legacyReferenceResolver: LegacyReferenceResolver - - mutable showFullPaths: bool - mutable diagnosticStyle: DiagnosticStyle - mutable utf8output: bool - mutable flatErrors: bool - - mutable maxErrors: int - mutable abortOnError: bool (* intended for fsi scripts that should exit on first error *) - mutable baseAddress: int32 option - mutable checksumAlgorithm: HashAlgorithm + mutable primaryAssembly: PrimaryAssembly + mutable noFeedback: bool + mutable stackReserveSize: int32 option + mutable implicitIncludeDir: string (* normally "." *) + mutable openDebugInformationForLaterStaticLinking: bool (* only for --standalone *) + defaultFSharpBinariesDir: string + mutable compilingFSharpCore: bool + mutable useIncrementalBuilder: bool + mutable includes: string list + mutable implicitOpens: string list + mutable useFsiAuxLib: bool + mutable implicitlyReferenceDotNetAssemblies: bool + mutable resolutionEnvironment: LegacyResolutionEnvironment + mutable implicitlyResolveAssemblies: bool + mutable indentationAwareSyntax: bool option + mutable conditionalDefines: string list + mutable loadedSources: (range * string * string) list + mutable compilerToolPaths: string list + mutable referencedDLLs: AssemblyReference list + mutable packageManagerLines: Map + mutable projectReferences: IProjectReference list + mutable knownUnresolvedReferences: UnresolvedAssemblyReference list + reduceMemoryUsage: ReduceMemoryFlag + mutable subsystemVersion: int * int + mutable useHighEntropyVA: bool + mutable inputCodePage: int option + mutable embedResources: string list + mutable diagnosticsOptions: FSharpDiagnosticOptions + mutable mlCompatibility: bool + mutable checkOverflow: bool + mutable showReferenceResolutions: bool + mutable outputDir: string option + mutable outputFile: string option + mutable platform: ILPlatform option + mutable prefer32Bit: bool + mutable useSimpleResolution: bool + mutable target: CompilerTarget + mutable debuginfo: bool + mutable testFlagEmitFeeFeeAs100001: bool + mutable dumpDebugInfo: bool + mutable debugSymbolFile: string option + (* Backend configuration *) + mutable typeCheckOnly: bool + mutable parseOnly: bool + mutable importAllReferencesOnly: bool + mutable simulateException: string option + mutable printAst: bool + mutable tokenize: TokenizeOption + mutable testInteractionParser: bool + mutable reportNumDecls: bool + mutable printSignature: bool + mutable printSignatureFile: string + mutable printAllSignatureFiles: bool + mutable xmlDocOutputFile: string option + mutable stats: bool + mutable generateFilterBlocks: bool (* don't generate filter blocks due to bugs on Mono *) + + mutable signer: string option + mutable container: string option + + mutable delaysign: bool + mutable publicsign: bool + mutable version: VersionFlag + mutable metadataVersion: string option + mutable standalone: bool + mutable extraStaticLinkRoots: string list + mutable noSignatureData: bool + mutable onlyEssentialOptimizationData: bool + mutable useOptimizationDataFile: bool + mutable jitTracking: bool + mutable portablePDB: bool + mutable embeddedPDB: bool + mutable embedAllSource: bool + mutable embedSourceList: string list + mutable sourceLink: string + + mutable ignoreSymbolStoreSequencePoints: bool + mutable internConstantStrings: bool + mutable extraOptimizationIterations: int + + mutable win32icon: string + mutable win32res: string + mutable win32manifest: string + mutable includewin32manifest: bool + mutable linkResources: string list + + mutable legacyReferenceResolver: LegacyReferenceResolver + + mutable showFullPaths: bool + mutable diagnosticStyle: DiagnosticStyle + mutable utf8output: bool + mutable flatErrors: bool + + mutable maxErrors: int + mutable abortOnError: bool (* intended for fsi scripts that should exit on first error *) + mutable baseAddress: int32 option + mutable checksumAlgorithm: HashAlgorithm #if DEBUG - mutable showOptimizationData: bool + mutable showOptimizationData: bool #endif - mutable showTerms: bool (* show terms between passes? *) - mutable writeTermsToFiles: bool (* show terms to files? *) - mutable doDetuple: bool (* run detuple pass? *) - mutable doTLR: bool (* run TLR pass? *) - mutable doFinalSimplify: bool (* do final simplification pass *) - mutable optsOn: bool (* optimizations are turned on *) - mutable optSettings: Optimizer.OptimizationSettings - mutable emitTailcalls: bool - mutable deterministic: bool - mutable concurrentBuild: bool - mutable emitMetadataAssembly: MetadataAssemblyGeneration - mutable preferredUiLang: string option - mutable lcid: int option - mutable productNameForBannerText: string - /// show the MS (c) notice, e.g. with help or fsi? - mutable showBanner: bool - - /// show times between passes? - mutable showTimes: bool - mutable showLoadedAssemblies: bool - mutable continueAfterParseFailure: bool + mutable showTerms: bool (* show terms between passes? *) + mutable writeTermsToFiles: bool (* show terms to files? *) + mutable doDetuple: bool (* run detuple pass? *) + mutable doTLR: bool (* run TLR pass? *) + mutable doFinalSimplify: bool (* do final simplification pass *) + mutable optsOn: bool (* optimizations are turned on *) + mutable optSettings: Optimizer.OptimizationSettings + mutable emitTailcalls: bool + mutable deterministic: bool + mutable concurrentBuild: bool + mutable emitMetadataAssembly: MetadataAssemblyGeneration + mutable preferredUiLang: string option + mutable lcid: int option + mutable productNameForBannerText: string + /// show the MS (c) notice, e.g. with help or fsi? + mutable showBanner: bool + + /// show times between passes? + mutable showTimes: bool + mutable showLoadedAssemblies: bool + mutable continueAfterParseFailure: bool #if !NO_TYPEPROVIDERS - /// show messages about extension type resolution? - mutable showExtensionTypeMessages: bool + /// show messages about extension type resolution? + mutable showExtensionTypeMessages: bool #endif - /// Pause between passes? - mutable pause: bool - - /// Whenever possible, emit callvirt instead of call - mutable alwaysCallVirt: bool + /// Pause between passes? + mutable pause: bool - /// If true, strip away data that would not be of use to end users, but is useful to us for debugging - mutable noDebugAttributes: bool + /// Whenever possible, emit callvirt instead of call + mutable alwaysCallVirt: bool - /// If true, indicates all type checking and code generation is in the context of fsi.exe - isInteractive: bool + /// If true, strip away data that would not be of use to end users, but is useful to us for debugging + mutable noDebugAttributes: bool - isInvalidationSupported: bool + /// If true, indicates all type checking and code generation is in the context of fsi.exe + isInteractive: bool - /// If true - every expression in quotations will be augmented with full debug info (fileName, location in file) - mutable emitDebugInfoInQuotations: bool + isInvalidationSupported: bool - mutable exename: string option + /// If true - every expression in quotations will be augmented with full debug info (fileName, location in file) + mutable emitDebugInfoInQuotations: bool - // If true - the compiler will copy FSharp.Core.dll along the produced binaries - mutable copyFSharpCore: CopyFSharpCoreFlag + mutable exename: string option - /// When false FSI will lock referenced assemblies requiring process restart, false = disable Shadow Copy false (*default*) - mutable shadowCopyReferences: bool + // If true - the compiler will copy FSharp.Core.dll along the produced binaries + mutable copyFSharpCore: CopyFSharpCoreFlag - mutable useSdkRefs: bool + /// When false FSI will lock referenced assemblies requiring process restart, false = disable Shadow Copy false (*default*) + mutable shadowCopyReferences: bool - mutable fxResolver: FxResolver option + mutable useSdkRefs: bool - // Is F# Interactive using multi-assembly emit? - mutable fsiMultiAssemblyEmit: bool + mutable fxResolver: FxResolver option - /// specify the error range for FxResolver - rangeForErrors: range + // Is F# Interactive using multi-assembly emit? + mutable fsiMultiAssemblyEmit: bool - /// Override the SDK directory used by FxResolver, used for FCS only - sdkDirOverride: string option + /// specify the error range for FxResolver + rangeForErrors: range - /// A function to call to try to get an object that acts as a snapshot of the metadata section of a .NET binary, - /// and from which we can read the metadata. Only used when metadataOnly=true. - mutable tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot + /// Override the SDK directory used by FxResolver, used for FCS only + sdkDirOverride: string option - mutable internalTestSpanStackReferring: bool + /// A function to call to try to get an object that acts as a snapshot of the metadata section of a .NET binary, + /// and from which we can read the metadata. Only used when metadataOnly=true. + mutable tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot - mutable noConditionalErasure: bool + mutable internalTestSpanStackReferring: bool - mutable pathMap: PathMap + mutable noConditionalErasure: bool - mutable langVersion: LanguageVersion + mutable pathMap: PathMap - mutable xmlDocInfoLoader: IXmlDocumentationInfoLoader option - } + mutable langVersion: LanguageVersion + mutable xmlDocInfoLoader: IXmlDocumentationInfoLoader option + } // Directories to start probing in // Algorithm: @@ -532,12 +581,12 @@ type TcConfigBuilder = // // NOTE: it is important this is a delayed IEnumerable sequence. It is recomputed // each time a resolution happens and additional paths may be added as a result. - member tcConfigB.GetNativeProbingRoots () = + member tcConfigB.GetNativeProbingRoots() = seq { yield! tcConfigB.includes yield! tcConfigB.compilerToolPaths - yield! (tcConfigB.referencedDLLs |> Seq.map(fun ref -> Path.GetDirectoryName(ref.Text))) - yield tcConfigB.implicitIncludeDir + yield! (tcConfigB.referencedDLLs |> Seq.map (fun ref -> Path.GetDirectoryName(ref.Text))) + tcConfigB.implicitIncludeDir } |> Seq.distinct @@ -560,147 +609,147 @@ type TcConfigBuilder = // These are all default values, many can be overridden using the command line switch { - primaryAssembly = PrimaryAssembly.Mscorlib - indentationAwareSyntax = None - noFeedback = false - stackReserveSize = None - conditionalDefines = [] - openDebugInformationForLaterStaticLinking = false - compilingFSharpCore = false - useIncrementalBuilder = false - implicitOpens = [] - includes = [] - resolutionEnvironment = LegacyResolutionEnvironment.EditingOrCompilation false - implicitlyReferenceDotNetAssemblies = true - implicitlyResolveAssemblies = true - compilerToolPaths = [] - referencedDLLs = [] - packageManagerLines = Map.empty - projectReferences = [] - knownUnresolvedReferences = [] - loadedSources = [] - diagnosticsOptions = FSharpDiagnosticOptions.Default - embedResources = [] - inputCodePage = None - subsystemVersion = 4, 0 // per spec for 357994 - useHighEntropyVA = false - mlCompatibility = false - checkOverflow = false - showReferenceResolutions = false - outputDir = None - outputFile = None - platform = None - prefer32Bit = false - useSimpleResolution = runningOnMono - target = CompilerTarget.ConsoleExe - debuginfo = false - testFlagEmitFeeFeeAs100001 = false - dumpDebugInfo = false - debugSymbolFile = None - - (* Backend configuration *) - typeCheckOnly = false - parseOnly = false - importAllReferencesOnly = false - simulateException = None - printAst = false - tokenize = TokenizeOption.AndCompile - testInteractionParser = false - reportNumDecls = false - printSignature = false - printSignatureFile = "" - printAllSignatureFiles = false - xmlDocOutputFile = None - stats = false - generateFilterBlocks = false (* don't generate filter blocks *) - - signer = None - container = None - maxErrors = 100 - abortOnError = false - baseAddress = None - checksumAlgorithm = HashAlgorithm.Sha256 - - delaysign = false - publicsign = false - version = VersionNone - metadataVersion = None - standalone = false - extraStaticLinkRoots = [] - noSignatureData = false - onlyEssentialOptimizationData = false - useOptimizationDataFile = false - jitTracking = true - portablePDB = true - embeddedPDB = false - embedAllSource = false - embedSourceList = [] - sourceLink = "" - ignoreSymbolStoreSequencePoints = false - internConstantStrings = true - extraOptimizationIterations = 0 - - win32icon = "" - win32res = "" - win32manifest = "" - includewin32manifest = true - linkResources = [] - showFullPaths = false - diagnosticStyle = DiagnosticStyle.Default - - utf8output = false - flatErrors = false - - #if DEBUG - showOptimizationData = false - #endif - showTerms = false - writeTermsToFiles = false - - doDetuple = false - doTLR = false - doFinalSimplify = false - optsOn = false - optSettings = Optimizer.OptimizationSettings.Defaults - emitTailcalls = true - deterministic = false - concurrentBuild = true - emitMetadataAssembly = MetadataAssemblyGeneration.None - preferredUiLang = None - lcid = None - productNameForBannerText = FSharpProductName - showBanner = true - showTimes = false - showLoadedAssemblies = false - continueAfterParseFailure = false + primaryAssembly = PrimaryAssembly.Mscorlib + indentationAwareSyntax = None + noFeedback = false + stackReserveSize = None + conditionalDefines = [] + openDebugInformationForLaterStaticLinking = false + compilingFSharpCore = false + useIncrementalBuilder = false + implicitOpens = [] + includes = [] + resolutionEnvironment = LegacyResolutionEnvironment.EditingOrCompilation false + implicitlyReferenceDotNetAssemblies = true + implicitlyResolveAssemblies = true + compilerToolPaths = [] + referencedDLLs = [] + packageManagerLines = Map.empty + projectReferences = [] + knownUnresolvedReferences = [] + loadedSources = [] + diagnosticsOptions = FSharpDiagnosticOptions.Default + embedResources = [] + inputCodePage = None + subsystemVersion = 4, 0 // per spec for 357994 + useHighEntropyVA = false + mlCompatibility = false + checkOverflow = false + showReferenceResolutions = false + outputDir = None + outputFile = None + platform = None + prefer32Bit = false + useSimpleResolution = runningOnMono + target = CompilerTarget.ConsoleExe + debuginfo = false + testFlagEmitFeeFeeAs100001 = false + dumpDebugInfo = false + debugSymbolFile = None + + (* Backend configuration *) + typeCheckOnly = false + parseOnly = false + importAllReferencesOnly = false + simulateException = None + printAst = false + tokenize = TokenizeOption.AndCompile + testInteractionParser = false + reportNumDecls = false + printSignature = false + printSignatureFile = "" + printAllSignatureFiles = false + xmlDocOutputFile = None + stats = false + generateFilterBlocks = false (* don't generate filter blocks *) + + signer = None + container = None + maxErrors = 100 + abortOnError = false + baseAddress = None + checksumAlgorithm = HashAlgorithm.Sha256 + + delaysign = false + publicsign = false + version = VersionNone + metadataVersion = None + standalone = false + extraStaticLinkRoots = [] + noSignatureData = false + onlyEssentialOptimizationData = false + useOptimizationDataFile = false + jitTracking = true + portablePDB = true + embeddedPDB = false + embedAllSource = false + embedSourceList = [] + sourceLink = "" + ignoreSymbolStoreSequencePoints = false + internConstantStrings = true + extraOptimizationIterations = 0 + + win32icon = "" + win32res = "" + win32manifest = "" + includewin32manifest = true + linkResources = [] + showFullPaths = false + diagnosticStyle = DiagnosticStyle.Default + + utf8output = false + flatErrors = false + +#if DEBUG + showOptimizationData = false +#endif + showTerms = false + writeTermsToFiles = false + + doDetuple = false + doTLR = false + doFinalSimplify = false + optsOn = false + optSettings = Optimizer.OptimizationSettings.Defaults + emitTailcalls = true + deterministic = false + concurrentBuild = true + emitMetadataAssembly = MetadataAssemblyGeneration.None + preferredUiLang = None + lcid = None + productNameForBannerText = FSharpProductName + showBanner = true + showTimes = false + showLoadedAssemblies = false + continueAfterParseFailure = false #if !NO_TYPEPROVIDERS - showExtensionTypeMessages = false + showExtensionTypeMessages = false #endif - pause = false - alwaysCallVirt = true - noDebugAttributes = false - emitDebugInfoInQuotations = false - exename = None - shadowCopyReferences = false - useSdkRefs = true - fxResolver = None - fsiMultiAssemblyEmit = true - internalTestSpanStackReferring = false - noConditionalErasure = false - pathMap = PathMap.empty - langVersion = LanguageVersion.Default - implicitIncludeDir = implicitIncludeDir - defaultFSharpBinariesDir = defaultFSharpBinariesDir - reduceMemoryUsage = reduceMemoryUsage - legacyReferenceResolver = legacyReferenceResolver - isInteractive = isInteractive - isInvalidationSupported = isInvalidationSupported - copyFSharpCore = defaultCopyFSharpCore - tryGetMetadataSnapshot = tryGetMetadataSnapshot - useFsiAuxLib = isInteractive - rangeForErrors = rangeForErrors - sdkDirOverride = sdkDirOverride - xmlDocInfoLoader = None + pause = false + alwaysCallVirt = true + noDebugAttributes = false + emitDebugInfoInQuotations = false + exename = None + shadowCopyReferences = false + useSdkRefs = true + fxResolver = None + fsiMultiAssemblyEmit = true + internalTestSpanStackReferring = false + noConditionalErasure = false + pathMap = PathMap.empty + langVersion = LanguageVersion.Default + implicitIncludeDir = implicitIncludeDir + defaultFSharpBinariesDir = defaultFSharpBinariesDir + reduceMemoryUsage = reduceMemoryUsage + legacyReferenceResolver = legacyReferenceResolver + isInteractive = isInteractive + isInvalidationSupported = isInvalidationSupported + copyFSharpCore = defaultCopyFSharpCore + tryGetMetadataSnapshot = tryGetMetadataSnapshot + useFsiAuxLib = isInteractive + rangeForErrors = rangeForErrors + sdkDirOverride = sdkDirOverride + xmlDocInfoLoader = None } member tcConfigB.FxResolver = @@ -709,7 +758,17 @@ type TcConfigBuilder = match tcConfigB.fxResolver with | None -> let useDotNetFramework = (tcConfigB.primaryAssembly = PrimaryAssembly.Mscorlib) - let fxResolver = FxResolver(useDotNetFramework, tcConfigB.implicitIncludeDir, rangeForErrors=tcConfigB.rangeForErrors, useSdkRefs=tcConfigB.useSdkRefs, isInteractive=tcConfigB.isInteractive, sdkDirOverride=tcConfigB.sdkDirOverride) + + let fxResolver = + FxResolver( + useDotNetFramework, + tcConfigB.implicitIncludeDir, + rangeForErrors = tcConfigB.rangeForErrors, + useSdkRefs = tcConfigB.useSdkRefs, + isInteractive = tcConfigB.isInteractive, + sdkDirOverride = tcConfigB.sdkDirOverride + ) + tcConfigB.fxResolver <- Some fxResolver fxResolver | Some fxResolver -> fxResolver @@ -724,93 +783,140 @@ type TcConfigBuilder = member tcConfigB.ResolveSourceFile(m, nm, pathLoadedFrom) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter - let paths = seq { yield! tcConfigB.includes; yield pathLoadedFrom } + + let paths = + seq { + yield! tcConfigB.includes + yield pathLoadedFrom + } + ResolveFileUsingPaths(paths, m, nm) /// Decide names of output file, pdb and assembly member tcConfigB.DecideNames sourceFiles = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter - if sourceFiles = [] then errorR(Error(FSComp.SR.buildNoInputsSpecified(), rangeCmdArgs)) - let ext() = match tcConfigB.target with CompilerTarget.Dll -> ".dll" | CompilerTarget.Module -> ".netmodule" | CompilerTarget.ConsoleExe | CompilerTarget.WinExe -> ".exe" - let implFiles = sourceFiles |> List.filter (fun fileName -> List.exists (FileSystemUtils.checkSuffix fileName) FSharpImplFileSuffixes) + + if sourceFiles = [] then + errorR (Error(FSComp.SR.buildNoInputsSpecified (), rangeCmdArgs)) + + let ext () = + match tcConfigB.target with + | CompilerTarget.Dll -> ".dll" + | CompilerTarget.Module -> ".netmodule" + | CompilerTarget.ConsoleExe + | CompilerTarget.WinExe -> ".exe" + + let implFiles = + sourceFiles + |> List.filter (fun fileName -> List.exists (FileSystemUtils.checkSuffix fileName) FSharpImplFileSuffixes) + let outfile = match tcConfigB.outputFile, List.rev implFiles with - | None, [] -> "out" + ext() + | None, [] -> "out" + ext () | None, h :: _ -> let basic = FileSystemUtils.fileNameOfPath h - let modname = try FileSystemUtils.chopExtension basic with _ -> basic - modname+(ext()) + + let modname = + try + FileSystemUtils.chopExtension basic + with _ -> + basic + + modname + (ext ()) | Some f, _ -> f + let assemblyName = let baseName = FileSystemUtils.fileNameOfPath outfile (FileSystemUtils.fileNameWithoutExtension baseName) let pdbfile = if tcConfigB.debuginfo then - Some (match tcConfigB.debugSymbolFile with + Some( + match tcConfigB.debugSymbolFile with | None -> getDebugFileName outfile tcConfigB.portablePDB #if ENABLE_MONO_SUPPORT | Some _ when runningOnMono -> // On Mono, the name of the debug file has to be ".mdb" so specifying it explicitly is an error - warning(Error(FSComp.SR.ilwriteMDBFileNameCannotBeChangedWarning(), rangeCmdArgs)) + warning (Error(FSComp.SR.ilwriteMDBFileNameCannotBeChangedWarning (), rangeCmdArgs)) getDebugFileName outfile tcConfigB.portablePDB #endif - | Some f -> f) + | Some f -> f + ) elif (tcConfigB.debugSymbolFile <> None) && (not tcConfigB.debuginfo) then - error(Error(FSComp.SR.buildPdbRequiresDebug(), rangeStartup)) + error (Error(FSComp.SR.buildPdbRequiresDebug (), rangeStartup)) else None + tcConfigB.outputFile <- Some outfile outfile, pdbfile, assemblyName member tcConfigB.TurnWarningOff(m, s: string) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter + match GetWarningNumber(m, s) with | None -> () | Some n -> // nowarn:62 turns on mlCompatibility, e.g. shows ML compat items in intellisense menus if n = 62 then tcConfigB.mlCompatibility <- true + tcConfigB.diagnosticsOptions <- - { tcConfigB.diagnosticsOptions with WarnOff = ListSet.insert (=) n tcConfigB.diagnosticsOptions.WarnOff } + { tcConfigB.diagnosticsOptions with + WarnOff = ListSet.insert (=) n tcConfigB.diagnosticsOptions.WarnOff + } member tcConfigB.TurnWarningOn(m, s: string) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter + match GetWarningNumber(m, s) with | None -> () | Some n -> // warnon 62 turns on mlCompatibility, e.g. shows ML compat items in intellisense menus if n = 62 then tcConfigB.mlCompatibility <- false + tcConfigB.diagnosticsOptions <- - { tcConfigB.diagnosticsOptions with WarnOn = ListSet.insert (=) n tcConfigB.diagnosticsOptions.WarnOn } + { tcConfigB.diagnosticsOptions with + WarnOn = ListSet.insert (=) n tcConfigB.diagnosticsOptions.WarnOn + } - member tcConfigB.AddIncludePath (m, path, pathIncludedFrom) = + member tcConfigB.AddIncludePath(m, path, pathIncludedFrom) = let absolutePath = ComputeMakePathAbsolute pathIncludedFrom path let ok = let existsOpt = - try Some(FileSystem.DirectoryExistsShim absolutePath) - with _ -> warning(Error(FSComp.SR.buildInvalidSearchDirectory path, m)); None + try + Some(FileSystem.DirectoryExistsShim absolutePath) + with _ -> + warning (Error(FSComp.SR.buildInvalidSearchDirectory path, m)) + None match existsOpt with | Some exists -> - if not exists then warning(Error(FSComp.SR.buildSearchDirectoryNotFound absolutePath, m)) + if not exists then + warning (Error(FSComp.SR.buildSearchDirectoryNotFound absolutePath, m)) + exists | None -> false if ok && not (List.contains absolutePath tcConfigB.includes) then - tcConfigB.includes <- tcConfigB.includes ++ absolutePath + tcConfigB.includes <- tcConfigB.includes ++ absolutePath member tcConfigB.AddLoadedSource(m, originalPath, pathLoadedFrom) = if FileSystem.IsInvalidPathShim originalPath then - warning(Error(FSComp.SR.buildInvalidFilename originalPath, m)) + warning (Error(FSComp.SR.buildInvalidFilename originalPath, m)) else let path = - let paths = seq { yield! tcConfigB.includes; yield pathLoadedFrom } + let paths = + seq { + yield! tcConfigB.includes + yield pathLoadedFrom + } + match TryResolveFileUsingPaths(paths, m, originalPath) with | Some path -> path | None -> - // File doesn't exist in the paths. Assume it will be in the load-ed from directory. - ComputeMakePathAbsolute pathLoadedFrom originalPath + // File doesn't exist in the paths. Assume it will be in the load-ed from directory. + ComputeMakePathAbsolute pathLoadedFrom originalPath + if not (List.contains path (List.map (fun (_, _, path) -> path) tcConfigB.loadedSources)) then tcConfigB.loadedSources <- tcConfigB.loadedSources ++ (m, originalPath, path) @@ -821,74 +927,92 @@ type TcConfigBuilder = tcConfigB.embedResources <- tcConfigB.embedResources ++ fileName member tcConfigB.AddCompilerToolsByPath path = - if not (tcConfigB.compilerToolPaths |> List.exists (fun text -> path = text)) then // NOTE: We keep same paths if range is different. - let compilerToolPath = tcConfigB.compilerToolPaths |> List.tryPick (fun text -> if text = path then Some text else None) + if not (tcConfigB.compilerToolPaths |> List.exists (fun text -> path = text)) then // NOTE: We keep same paths if range is different. + let compilerToolPath = + tcConfigB.compilerToolPaths + |> List.tryPick (fun text -> if text = path then Some text else None) + if compilerToolPath.IsNone then tcConfigB.compilerToolPaths <- tcConfigB.compilerToolPaths ++ path - member tcConfigB.AddReferencedAssemblyByPath (m, path) = + member tcConfigB.AddReferencedAssemblyByPath(m, path) = if FileSystem.IsInvalidPathShim path then - warning(Error(FSComp.SR.buildInvalidAssemblyName(path), m)) - elif not (tcConfigB.referencedDLLs |> List.exists (fun ar2 -> equals m ar2.Range && path=ar2.Text)) then // NOTE: We keep same paths if range is different. - let projectReference = tcConfigB.projectReferences |> List.tryPick (fun pr -> if pr.FileName = path then Some pr else None) - tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs ++ AssemblyReference(m, path, projectReference) - - member tcConfigB.AddDependencyManagerText (packageManager: IDependencyManagerProvider, lt, m, path: string) = + warning (Error(FSComp.SR.buildInvalidAssemblyName (path), m)) + elif + not + ( + tcConfigB.referencedDLLs + |> List.exists (fun ar2 -> equals m ar2.Range && path = ar2.Text) + ) + then // NOTE: We keep same paths if range is different. + let projectReference = + tcConfigB.projectReferences + |> List.tryPick (fun pr -> if pr.FileName = path then Some pr else None) + + tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs ++ AssemblyReference(m, path, projectReference) + + member tcConfigB.AddDependencyManagerText(packageManager: IDependencyManagerProvider, lt, m, path: string) = tcConfigB.packageManagerLines <- PackageManagerLine.AddLineWithKey packageManager.Key lt path m tcConfigB.packageManagerLines - member tcConfigB.AddReferenceDirective (dependencyProvider: DependencyProvider, m, path: string, directive) = + member tcConfigB.AddReferenceDirective(dependencyProvider: DependencyProvider, m, path: string, directive) = let output = tcConfigB.outputDir |> Option.defaultValue "" let reportError = - ResolvingErrorReport (fun errorType err msg -> + ResolvingErrorReport(fun errorType err msg -> let error = err, msg + match errorType with - | ErrorReportType.Warning -> warning(Error(error, m)) - | ErrorReportType.Error -> errorR(Error(error, m))) + | ErrorReportType.Warning -> warning (Error(error, m)) + | ErrorReportType.Error -> errorR (Error(error, m))) - let dm = dependencyProvider.TryFindDependencyManagerInPath(tcConfigB.compilerToolPaths, output, reportError, path) + let dm = + dependencyProvider.TryFindDependencyManagerInPath(tcConfigB.compilerToolPaths, output, reportError, path) match dm with // #r "Assembly" - | NonNull path, Null -> - tcConfigB.AddReferencedAssemblyByPath (m, path) + | NonNull path, Null -> tcConfigB.AddReferencedAssemblyByPath(m, path) | _, NonNull dependencyManager -> if tcConfigB.langVersion.SupportsFeature(LanguageFeature.PackageManagement) then - tcConfigB.AddDependencyManagerText (dependencyManager, directive, m, path) + tcConfigB.AddDependencyManagerText(dependencyManager, directive, m, path) else - errorR(Error(FSComp.SR.packageManagementRequiresVFive(), m)) + errorR (Error(FSComp.SR.packageManagementRequiresVFive (), m)) - | Null, Null when directive = Directive.Include -> - errorR(Error(FSComp.SR.poundiNotSupportedByRegisteredDependencyManagers(), m)) + | Null, Null when directive = Directive.Include -> errorR (Error(FSComp.SR.poundiNotSupportedByRegisteredDependencyManagers (), m)) - | Null, Null -> - errorR(Error(FSComp.SR.buildInvalidHashrDirective(), m)) + | Null, Null -> errorR (Error(FSComp.SR.buildInvalidHashrDirective (), m)) - member tcConfigB.RemoveReferencedAssemblyByPath (m, path) = - tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs |> List.filter (fun ar -> not (equals ar.Range m) || ar.Text <> path) + member tcConfigB.RemoveReferencedAssemblyByPath(m, path) = + tcConfigB.referencedDLLs <- + tcConfigB.referencedDLLs + |> List.filter (fun ar -> not (equals ar.Range m) || ar.Text <> path) - member tcConfigB.AddPathMapping (oldPrefix, newPrefix) = + member tcConfigB.AddPathMapping(oldPrefix, newPrefix) = tcConfigB.pathMap <- tcConfigB.pathMap |> PathMap.addMapping oldPrefix newPrefix - static member SplitCommandLineResourceInfo (ri: string) = + static member SplitCommandLineResourceInfo(ri: string) = let p = ri.IndexOf ',' + if p <> -1 then let file = String.sub ri 0 p - let rest = String.sub ri (p+1) (String.length ri - p - 1) + let rest = String.sub ri (p + 1) (String.length ri - p - 1) let p = rest.IndexOf ',' + if p <> -1 then - let name = String.sub rest 0 p+".resources" - let pubpri = String.sub rest (p+1) (rest.Length - p - 1) - if pubpri = "public" then file, name, ILResourceAccess.Public - elif pubpri = "private" then file, name, ILResourceAccess.Private - else error(Error(FSComp.SR.buildInvalidPrivacy pubpri, rangeStartup)) + let name = String.sub rest 0 p + ".resources" + let pubpri = String.sub rest (p + 1) (rest.Length - p - 1) + + if pubpri = "public" then + file, name, ILResourceAccess.Public + elif pubpri = "private" then + file, name, ILResourceAccess.Private + else + error (Error(FSComp.SR.buildInvalidPrivacy pubpri, rangeStartup)) else file, rest, ILResourceAccess.Public else ri, FileSystemUtils.fileNameOfPath ri, ILResourceAccess.Public - //---------------------------------------------------------------------------- // TcConfig //-------------------------------------------------------------------------- @@ -899,33 +1023,51 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = // Validate the inputs - this helps ensure errors in options are shown in visual studio rather than only when built // However we only validate a minimal number of options at the moment - do if validate then try data.version.GetVersionInfo(data.implicitIncludeDir) |> ignore with e -> errorR e + do + if validate then + try + data.version.GetVersionInfo(data.implicitIncludeDir) |> ignore + with e -> + errorR e // clone the input builder to ensure nobody messes with it. let data = { data with pause = data.pause } let computeKnownDllReference libraryName = - let defaultCoreLibraryReference = AssemblyReference(range0, libraryName+".dll", None) + let defaultCoreLibraryReference = + AssemblyReference(range0, libraryName + ".dll", None) + let nameOfDll (assemRef: AssemblyReference) = let fileName = ComputeMakePathAbsolute data.implicitIncludeDir assemRef.Text + if FileSystem.FileExistsShim fileName then assemRef, Some fileName else // If the file doesn't exist, let reference resolution logic report the error later... - defaultCoreLibraryReference, if equals assemRef.Range rangeStartup then Some fileName else None - match data.referencedDLLs |> List.filter (fun assemblyReference -> assemblyReference.SimpleAssemblyNameIs libraryName) with + defaultCoreLibraryReference, + if equals assemRef.Range rangeStartup then + Some fileName + else + None + + match data.referencedDLLs + |> List.filter (fun assemblyReference -> assemblyReference.SimpleAssemblyNameIs libraryName) + with | [] -> defaultCoreLibraryReference, None - | [r] + | [ r ] | r :: _ -> nameOfDll r // Look for an explicit reference to mscorlib/netstandard.dll or System.Runtime.dll and use that to compute clrRoot and targetFrameworkVersion - let primaryAssemblyReference, primaryAssemblyExplicitFilenameOpt = computeKnownDllReference(data.primaryAssembly.Name) + let primaryAssemblyReference, primaryAssemblyExplicitFilenameOpt = + computeKnownDllReference (data.primaryAssembly.Name) + let fslibReference = // Look for explicit FSharp.Core reference otherwise use version that was referenced by compiler let dllReference, fileNameOpt = computeKnownDllReference getFSharpCoreLibraryName + match fileNameOpt with | Some _ -> dllReference - | None -> AssemblyReference(range0, getDefaultFSharpCoreLocation(), None) + | None -> AssemblyReference(range0, getDefaultFSharpCoreLocation (), None) // clrRoot: the location of the primary assembly (mscorlib.dll or netstandard.dll or System.Runtime.dll) // @@ -938,13 +1080,15 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = let clrRootValue, targetFrameworkVersionValue = match primaryAssemblyExplicitFilenameOpt with | Some primaryAssemblyFilename -> - let fileName = ComputeMakePathAbsolute data.implicitIncludeDir primaryAssemblyFilename + let fileName = + ComputeMakePathAbsolute data.implicitIncludeDir primaryAssemblyFilename + try let clrRoot = Some(Path.GetDirectoryName(FileSystem.GetFullPathShim fileName)) clrRoot, data.legacyReferenceResolver.Impl.HighestInstalledNetFrameworkVersion() with e -> // We no longer expect the above to fail but leaving this just in case - error(Error(FSComp.SR.buildErrorOpeningBinaryFile(fileName, e.Message), rangeStartup)) + error (Error(FSComp.SR.buildErrorOpeningBinaryFile (fileName, e.Message), rangeStartup)) | None -> #if !ENABLE_MONO_SUPPORT // TODO: we have to get msbuild out of this @@ -952,87 +1096,96 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = None, "" else #endif - None, data.legacyReferenceResolver.Impl.HighestInstalledNetFrameworkVersion() + None, data.legacyReferenceResolver.Impl.HighestInstalledNetFrameworkVersion() let makePathAbsolute path = ComputeMakePathAbsolute data.implicitIncludeDir path let targetFrameworkDirectories = try - [ - // Check if we are given an explicit framework root - if so, use that - match clrRootValue with - | Some x -> - let clrRoot = makePathAbsolute x - yield clrRoot - let clrFacades = Path.Combine(clrRoot, "Facades") - if FileSystem.DirectoryExistsShim(clrFacades) then yield clrFacades - - | None -> -// "there is no really good notion of runtime directory on .NETCore" + [ + // Check if we are given an explicit framework root - if so, use that + match clrRootValue with + | Some x -> + let clrRoot = makePathAbsolute x + yield clrRoot + let clrFacades = Path.Combine(clrRoot, "Facades") + + if FileSystem.DirectoryExistsShim(clrFacades) then + yield clrFacades + + | None -> + // "there is no really good notion of runtime directory on .NETCore" #if NETSTANDARD - let runtimeRoot = Path.GetDirectoryName(typeof.Assembly.Location) + let runtimeRoot = Path.GetDirectoryName(typeof.Assembly.Location) #else - let runtimeRoot = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() + let runtimeRoot = + System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() #endif - let runtimeRootWithoutSlash = runtimeRoot.TrimEnd('/', '\\') - let runtimeRootFacades = Path.Combine(runtimeRootWithoutSlash, "Facades") - let runtimeRootWPF = Path.Combine(runtimeRootWithoutSlash, "WPF") - - match data.resolutionEnvironment with - | LegacyResolutionEnvironment.CompilationAndEvaluation -> - // Default compilation-and-execution-time references on .NET Framework and Mono, e.g. for F# Interactive - // - // In the current way of doing things, F# Interactive refers to implementation assemblies. - yield runtimeRoot - if FileSystem.DirectoryExistsShim runtimeRootFacades then - yield runtimeRootFacades // System.Runtime.dll is in /usr/lib/mono/4.5/Facades - if FileSystem.DirectoryExistsShim runtimeRootWPF then - yield runtimeRootWPF // PresentationCore.dll is in C:\Windows\Microsoft.NET\Framework\v4.0.30319\WPF - - match data.FxResolver.GetFrameworkRefsPackDirectory() with - | Some path when FileSystem.DirectoryExistsShim(path) -> - yield path - | _ -> () - - | LegacyResolutionEnvironment.EditingOrCompilation _ -> -#if ENABLE_MONO_SUPPORT - if runningOnMono then - // Default compilation-time references on Mono + let runtimeRootWithoutSlash = runtimeRoot.TrimEnd('/', '\\') + let runtimeRootFacades = Path.Combine(runtimeRootWithoutSlash, "Facades") + let runtimeRootWPF = Path.Combine(runtimeRootWithoutSlash, "WPF") + + match data.resolutionEnvironment with + | LegacyResolutionEnvironment.CompilationAndEvaluation -> + // Default compilation-and-execution-time references on .NET Framework and Mono, e.g. for F# Interactive // - // On Mono, the default references come from the implementation assemblies. - // This is because we have had trouble reliably using MSBuild APIs to compute DotNetFrameworkReferenceAssembliesRootDirectory on Mono. + // In the current way of doing things, F# Interactive refers to implementation assemblies. yield runtimeRoot + if FileSystem.DirectoryExistsShim runtimeRootFacades then yield runtimeRootFacades // System.Runtime.dll is in /usr/lib/mono/4.5/Facades + if FileSystem.DirectoryExistsShim runtimeRootWPF then yield runtimeRootWPF // PresentationCore.dll is in C:\Windows\Microsoft.NET\Framework\v4.0.30319\WPF - // On Mono we also add a default reference to the 4.5-api and 4.5-api/Facades directories. - let runtimeRootApi = runtimeRootWithoutSlash + "-api" - let runtimeRootApiFacades = Path.Combine(runtimeRootApi, "Facades") - if FileSystem.DirectoryExistsShim runtimeRootApi then - yield runtimeRootApi - if FileSystem.DirectoryExistsShim runtimeRootApiFacades then - yield runtimeRootApiFacades - else + + match data.FxResolver.GetFrameworkRefsPackDirectory() with + | Some path when FileSystem.DirectoryExistsShim(path) -> yield path + | _ -> () + + | LegacyResolutionEnvironment.EditingOrCompilation _ -> +#if ENABLE_MONO_SUPPORT + if runningOnMono then + // Default compilation-time references on Mono + // + // On Mono, the default references come from the implementation assemblies. + // This is because we have had trouble reliably using MSBuild APIs to compute DotNetFrameworkReferenceAssembliesRootDirectory on Mono. + yield runtimeRoot + + if FileSystem.DirectoryExistsShim runtimeRootFacades then + yield runtimeRootFacades // System.Runtime.dll is in /usr/lib/mono/4.5/Facades + + if FileSystem.DirectoryExistsShim runtimeRootWPF then + yield runtimeRootWPF // PresentationCore.dll is in C:\Windows\Microsoft.NET\Framework\v4.0.30319\WPF + // On Mono we also add a default reference to the 4.5-api and 4.5-api/Facades directories. + let runtimeRootApi = runtimeRootWithoutSlash + "-api" + let runtimeRootApiFacades = Path.Combine(runtimeRootApi, "Facades") + + if FileSystem.DirectoryExistsShim runtimeRootApi then + yield runtimeRootApi + + if FileSystem.DirectoryExistsShim runtimeRootApiFacades then + yield runtimeRootApiFacades + else #endif // Default compilation-time references on .NET Framework // // This is the normal case for "fsc.exe a.fs". We refer to the reference assemblies folder. - let frameworkRoot = data.legacyReferenceResolver.Impl.DotNetFrameworkReferenceAssembliesRootDirectory + let frameworkRoot = + data.legacyReferenceResolver.Impl.DotNetFrameworkReferenceAssembliesRootDirectory + let frameworkRootVersion = Path.Combine(frameworkRoot, targetFrameworkVersionValue) yield frameworkRootVersion let facades = Path.Combine(frameworkRootVersion, "Facades") - if FileSystem.DirectoryExistsShim facades then - yield facades + if FileSystem.DirectoryExistsShim facades then yield facades + match data.FxResolver.GetFrameworkRefsPackDirectory() with - | Some path when FileSystem.DirectoryExistsShim(path) -> - yield path + | Some path when FileSystem.DirectoryExistsShim(path) -> yield path | _ -> () - ] + ] with e -> - errorRecovery e range0; [] - + errorRecovery e range0 + [] member _.fsiMultiAssemblyEmit = data.fsiMultiAssemblyEmit member _.FxResolver = data.FxResolver @@ -1040,7 +1193,10 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.noFeedback = data.noFeedback member _.stackReserveSize = data.stackReserveSize member _.implicitIncludeDir = data.implicitIncludeDir - member _.openDebugInformationForLaterStaticLinking = data.openDebugInformationForLaterStaticLinking + + member _.openDebugInformationForLaterStaticLinking = + data.openDebugInformationForLaterStaticLinking + member _.fsharpBinariesDir = data.defaultFSharpBinariesDir member _.compilingFSharpCore = data.compilingFSharpCore member _.useIncrementalBuilder = data.useIncrementalBuilder @@ -1108,7 +1264,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.embedAllSource = data.embedAllSource member _.embedSourceList = data.embedSourceList member _.sourceLink = data.sourceLink - member _.packageManagerLines = data.packageManagerLines + member _.packageManagerLines = data.packageManagerLines member _.ignoreSymbolStoreSequencePoints = data.ignoreSymbolStoreSequencePoints member _.internConstantStrings = data.internConstantStrings member _.extraOptimizationIterations = data.extraOptimizationIterations @@ -1124,7 +1280,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.maxErrors = data.maxErrors member _.baseAddress = data.baseAddress member _.checksumAlgorithm = data.checksumAlgorithm - #if DEBUG +#if DEBUG member _.showOptimizationData = data.showOptimizationData #endif member _.showTerms = data.showTerms @@ -1172,26 +1328,33 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.legacyReferenceResolver = data.legacyReferenceResolver member _.CloneToBuilder() = - { data with conditionalDefines=data.conditionalDefines } + { data with + conditionalDefines = data.conditionalDefines + } member tcConfig.ComputeCanContainEntryPoint(sourceFiles: string list) = - let n = sourceFiles.Length in - (sourceFiles |> List.mapi (fun i _ -> (i = n-1)), tcConfig.target.IsExe) + let n = sourceFiles.Length in (sourceFiles |> List.mapi (fun i _ -> (i = n - 1)), tcConfig.target.IsExe) // This call can fail if no CLR is found (this is the path to mscorlib) - member _.GetTargetFrameworkDirectories() = - targetFrameworkDirectories + member _.GetTargetFrameworkDirectories() = targetFrameworkDirectories member tcConfig.ComputeIndentationAwareSyntaxInitialStatus fileName = use _unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter - let indentationAwareSyntaxOnByDefault = List.exists (FileSystemUtils.checkSuffix fileName) FSharpIndentationAwareSyntaxFileSuffixes - if indentationAwareSyntaxOnByDefault then (tcConfig.indentationAwareSyntax <> Some false) else (tcConfig.indentationAwareSyntax = Some true ) + + let indentationAwareSyntaxOnByDefault = + List.exists (FileSystemUtils.checkSuffix fileName) FSharpIndentationAwareSyntaxFileSuffixes + + if indentationAwareSyntaxOnByDefault then + (tcConfig.indentationAwareSyntax <> Some false) + else + (tcConfig.indentationAwareSyntax = Some true) member tcConfig.GetAvailableLoadedSources() = use _unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter + let resolveLoadedSource (m, originalPath, path) = try - if not(FileSystem.FileExistsShim(path)) then + if not (FileSystem.FileExistsShim(path)) then let secondTrial = tcConfig.includes |> List.tryPick (fun root -> @@ -1199,27 +1362,29 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = if FileSystem.FileExistsShim(path) then Some path else None) match secondTrial with - | Some path -> Some(m,path) + | Some path -> Some(m, path) | None -> - error(LoadedSourceNotFoundIgnoring(path,m)) + error (LoadedSourceNotFoundIgnoring(path, m)) None - else Some(m,path) - with e -> errorRecovery e m; None + else + Some(m, path) + with e -> + errorRecovery e m + None - tcConfig.loadedSources - |> List.choose resolveLoadedSource - |> List.distinct + tcConfig.loadedSources |> List.choose resolveLoadedSource |> List.distinct // This is not the complete set of search paths, it is just the set // that is special to F# (as compared to MSBuild resolution) member tcConfig.GetSearchPathsForLibraryFiles() = - [ yield! tcConfig.GetTargetFrameworkDirectories() - yield! List.map tcConfig.MakePathAbsolute tcConfig.includes - yield tcConfig.implicitIncludeDir - yield tcConfig.fsharpBinariesDir ] + [ + yield! tcConfig.GetTargetFrameworkDirectories() + yield! List.map tcConfig.MakePathAbsolute tcConfig.includes + tcConfig.implicitIncludeDir + tcConfig.fsharpBinariesDir + ] - member _.MakePathAbsolute path = - makePathAbsolute path + member _.MakePathAbsolute path = makePathAbsolute path member _.ResolveSourceFile(m, fileName, pathLoadedFrom) = data.ResolveSourceFile(m, fileName, pathLoadedFrom) @@ -1239,20 +1404,23 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = /// /// Returning true may mean that the file is locked and/or placed into the /// 'framework' reference set that is potentially shared across multiple compilations. - member tcConfig.IsSystemAssembly (fileName: string) = + member tcConfig.IsSystemAssembly(fileName: string) = try - FileSystem.FileExistsShim fileName && - ((tcConfig.GetTargetFrameworkDirectories() |> List.exists (fun clrRoot -> clrRoot = Path.GetDirectoryName fileName)) || - (tcConfig.FxResolver.GetSystemAssemblies().Contains (FileSystemUtils.fileNameWithoutExtension fileName)) || - tcConfig.FxResolver.IsInReferenceAssemblyPackDirectory fileName) + FileSystem.FileExistsShim fileName + && ((tcConfig.GetTargetFrameworkDirectories() + |> List.exists (fun clrRoot -> clrRoot = Path.GetDirectoryName fileName)) + || (tcConfig + .FxResolver + .GetSystemAssemblies() + .Contains(FileSystemUtils.fileNameWithoutExtension fileName)) + || tcConfig.FxResolver.IsInReferenceAssemblyPackDirectory fileName) with _ -> false member tcConfig.GenerateSignatureData = not tcConfig.standalone && not tcConfig.noSignatureData - member tcConfig.GenerateOptimizationData = - tcConfig.GenerateSignatureData + member tcConfig.GenerateOptimizationData = tcConfig.GenerateSignatureData member tcConfig.assumeDotNetFramework = tcConfig.primaryAssembly = PrimaryAssembly.Mscorlib @@ -1261,13 +1429,16 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = /// but for F# Interactive it may be based on an underlying mutable TcConfigBuilder. type TcConfigProvider = | TcConfigProvider of (CompilationThreadToken -> TcConfig) - member x.Get ctok = (let (TcConfigProvider f) = x in f ctok) + + member x.Get ctok = + (let (TcConfigProvider f) = x in f ctok) /// Get a TcConfigProvider which will return only the exact TcConfig. static member Constant tcConfig = TcConfigProvider(fun _ctok -> tcConfig) /// Get a TcConfigProvider which will continue to respect changes in the underlying /// TcConfigBuilder rather than delivering snapshots. - static member BasedOnMutableBuilder tcConfigB = TcConfigProvider(fun _ctok -> TcConfig.Create(tcConfigB, validate=false)) + static member BasedOnMutableBuilder tcConfigB = + TcConfigProvider(fun _ctok -> TcConfig.Create(tcConfigB, validate = false)) let GetFSharpCoreLibraryName () = getFSharpCoreLibraryName diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi index bb8e859a010..202aa59b44e 100644 --- a/src/Compiler/Driver/CompilerConfig.fsi +++ b/src/Compiler/Driver/CompilerConfig.fsi @@ -99,7 +99,7 @@ and IProjectReference = abstract TryGetLogicalTimeStamp: cache: TimeStampCache -> DateTime option type AssemblyReference = - | AssemblyReference of range * string * IProjectReference option + | AssemblyReference of range: range * text: string * projectReference: IProjectReference option member Range: range @@ -854,6 +854,4 @@ val FSharpScriptFileSuffixes: string list /// File suffixes where #light is the default val FSharpIndentationAwareSyntaxFileSuffixes: string list -val doNotRequireNamespaceOrModuleSuffixes: string list - -val mlCompatSuffixes: string list +val FSharpMLCompatFileSuffixes: string list diff --git a/src/Compiler/Driver/CompilerDiagnostics.fs b/src/Compiler/Driver/CompilerDiagnostics.fs index bc3e1b5c9ce..a26d232746f 100644 --- a/src/Compiler/Driver/CompilerDiagnostics.fs +++ b/src/Compiler/Driver/CompilerDiagnostics.fs @@ -44,7 +44,7 @@ open FSharp.Compiler.TypedTreeOps [] module internal CompilerService = let showAssertForUnexpectedException = ref true -#endif // DEBUG +#endif /// This exception is an old-style way of reporting a diagnostic exception HashIncludeNotAllowedInNonScript of range @@ -76,279 +76,273 @@ exception DeprecatedCommandLineOptionNoDescription of string * range /// This exception is an old-style way of reporting a diagnostic exception InternalCommandLineOption of string * range -let GetRangeOfDiagnostic(diagnostic: PhasedDiagnostic) = - let rec RangeFromException exn = - match exn with - | ErrorFromAddingConstraint(_, exn2, _) -> RangeFromException exn2 +let GetRangeOfDiagnostic (diagnostic: PhasedDiagnostic) = + let rec RangeFromException exn = + match exn with + | ErrorFromAddingConstraint (_, exn2, _) -> RangeFromException exn2 #if !NO_TYPEPROVIDERS - | TypeProviders.ProvidedTypeResolutionNoRange exn -> RangeFromException exn - | TypeProviders.ProvidedTypeResolution(m, _) + | TypeProviders.ProvidedTypeResolutionNoRange exn -> RangeFromException exn + | TypeProviders.ProvidedTypeResolution (m, _) #endif - | ReservedKeyword(_, m) - | IndentationProblem(_, m) - | ErrorFromAddingTypeEquation(_, _, _, _, _, m) - | ErrorFromApplyingDefault(_, _, _, _, _, m) - | ErrorsFromAddingSubsumptionConstraint(_, _, _, _, _, _, m) - | FunctionExpected(_, _, m) - | BakedInMemberConstraintName(_, m) - | StandardOperatorRedefinitionWarning(_, m) - | BadEventTransformation m - | ParameterlessStructCtor m - | FieldNotMutable (_, _, m) - | Recursion (_, _, _, _, m) - | InvalidRuntimeCoercion(_, _, _, m) - | IndeterminateRuntimeCoercion(_, _, _, m) - | IndeterminateStaticCoercion (_, _, _, m) - | StaticCoercionShouldUseBox (_, _, _, m) - | CoercionTargetSealed(_, _, m) - | UpcastUnnecessary m - | QuotationTranslator.IgnoringPartOfQuotedTermWarning (_, m) - - | TypeTestUnnecessary m - | RuntimeCoercionSourceSealed(_, _, m) - | OverrideDoesntOverride(_, _, _, _, _, m) - | UnionPatternsBindDifferentNames m - | UnionCaseWrongArguments (_, _, _, m) - | TypeIsImplicitlyAbstract m - | RequiredButNotSpecified (_, _, _, _, m) - | FunctionValueUnexpected (_, _, m) - | UnitTypeExpected (_, _, m) - | UnitTypeExpectedWithEquality (_, _, m) - | UnitTypeExpectedWithPossiblePropertySetter (_, _, _, _, m) - | UnitTypeExpectedWithPossibleAssignment (_, _, _, _, m) - | UseOfAddressOfOperator m - | DeprecatedThreadStaticBindingWarning m - | NonUniqueInferredAbstractSlot (_, _, _, _, _, m) - | DefensiveCopyWarning (_, m) - | LetRecCheckedAtRuntime m - | UpperCaseIdentifierInPattern m - | NotUpperCaseConstructor m - | RecursiveUseCheckedAtRuntime (_, _, m) - | LetRecEvaluatedOutOfOrder (_, _, _, m) - | DiagnosticWithText (_, _, m) - | DiagnosticWithSuggestions (_, _, m, _, _) - | SyntaxError (_, m) - | InternalError (_, m) - | InterfaceNotRevealed(_, _, m) - | WrappedError (_, m) - | PatternMatchCompilation.MatchIncomplete (_, _, m) - | PatternMatchCompilation.EnumMatchIncomplete (_, _, m) - | PatternMatchCompilation.RuleNeverMatched m - | ValNotMutable(_, _, m) - | ValNotLocal(_, _, m) - | MissingFields(_, m) - | OverrideInIntrinsicAugmentation m - | IntfImplInIntrinsicAugmentation m - | OverrideInExtrinsicAugmentation m - | IntfImplInExtrinsicAugmentation m - | ValueRestriction(_, _, _, _, _, m) - | LetRecUnsound (_, _, m) - | ObsoleteError (_, m) - | ObsoleteWarning (_, m) - | Experimental (_, m) - | PossibleUnverifiableCode m - | UserCompilerMessage (_, _, m) - | Deprecated(_, m) - | LibraryUseOnly m - | FieldsFromDifferentTypes (_, _, _, m) - | IndeterminateType m - | TyconBadArgs(_, _, _, m) -> - Some m - - | FieldNotContained(_, _, _, arf, _, _) -> Some arf.Range - | ValueNotContained(_, _, _, aval, _, _) -> Some aval.Range - | UnionCaseNotContained(_, _, _, aval, _, _) -> Some aval.Id.idRange - | FSharpExceptionNotContained(_, _, aexnc, _, _) -> Some aexnc.Range - - | VarBoundTwice id - | UndefinedName(_, _, id, _) -> - Some id.idRange - - | Duplicate(_, _, m) - | NameClash(_, _, _, m, _, _, _) - | UnresolvedOverloading(_, _, _, m) - | UnresolvedConversionOperator (_, _, _, m) - | VirtualAugmentationOnNullValuedType m - | NonVirtualAugmentationOnNullValuedType m - | NonRigidTypar(_, _, _, _, _, m) - | ConstraintSolverTupleDiffLengths(_, _, _, m, _) - | ConstraintSolverInfiniteTypes(_, _, _, _, m, _) - | ConstraintSolverMissingConstraint(_, _, _, m, _) - | ConstraintSolverTypesNotInEqualityRelation(_, _, _, m, _, _) - | ConstraintSolverError(_, m, _) - | ConstraintSolverTypesNotInSubsumptionRelation(_, _, _, m, _) - | SelfRefObjCtor(_, m) -> - Some m - - | NotAFunction(_, _, mfun, _) -> - Some mfun - - | NotAFunctionButIndexer(_, _, _, mfun, _, _) -> - Some mfun - - | IllegalFileNameChar _ -> Some rangeCmdArgs - - | UnresolvedReferenceError(_, m) - | UnresolvedPathReference(_, _, m) - | DeprecatedCommandLineOptionFull(_, m) - | DeprecatedCommandLineOptionForHtmlDoc(_, m) - | DeprecatedCommandLineOptionSuggestAlternative(_, _, m) - | DeprecatedCommandLineOptionNoDescription(_, m) - | InternalCommandLineOption(_, m) - | HashIncludeNotAllowedInNonScript m - | HashReferenceNotAllowedInNonScript m - | HashDirectiveNotAllowedInNonScript m - | FileNameNotResolved(_, _, m) - | LoadedSourceNotFoundIgnoring(_, m) - | MSBuildReferenceResolutionWarning(_, _, m) - | MSBuildReferenceResolutionError(_, _, m) - | AssemblyNotResolved(_, m) - | HashLoadedSourceHasIssues(_, _, _, m) - | HashLoadedScriptConsideredSource m -> - Some m - // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as e -> - RangeFromException e.InnerException + | ReservedKeyword (_, m) + | IndentationProblem (_, m) + | ErrorFromAddingTypeEquation (_, _, _, _, _, m) + | ErrorFromApplyingDefault (_, _, _, _, _, m) + | ErrorsFromAddingSubsumptionConstraint (_, _, _, _, _, _, m) + | FunctionExpected (_, _, m) + | BakedInMemberConstraintName (_, m) + | StandardOperatorRedefinitionWarning (_, m) + | BadEventTransformation m + | ParameterlessStructCtor m + | FieldNotMutable (_, _, m) + | Recursion (_, _, _, _, m) + | InvalidRuntimeCoercion (_, _, _, m) + | IndeterminateRuntimeCoercion (_, _, _, m) + | IndeterminateStaticCoercion (_, _, _, m) + | StaticCoercionShouldUseBox (_, _, _, m) + | CoercionTargetSealed (_, _, m) + | UpcastUnnecessary m + | QuotationTranslator.IgnoringPartOfQuotedTermWarning (_, m) + + | TypeTestUnnecessary m + | RuntimeCoercionSourceSealed (_, _, m) + | OverrideDoesntOverride (_, _, _, _, _, m) + | UnionPatternsBindDifferentNames m + | UnionCaseWrongArguments (_, _, _, m) + | TypeIsImplicitlyAbstract m + | RequiredButNotSpecified (_, _, _, _, m) + | FunctionValueUnexpected (_, _, m) + | UnitTypeExpected (_, _, m) + | UnitTypeExpectedWithEquality (_, _, m) + | UnitTypeExpectedWithPossiblePropertySetter (_, _, _, _, m) + | UnitTypeExpectedWithPossibleAssignment (_, _, _, _, m) + | UseOfAddressOfOperator m + | DeprecatedThreadStaticBindingWarning m + | NonUniqueInferredAbstractSlot (_, _, _, _, _, m) + | DefensiveCopyWarning (_, m) + | LetRecCheckedAtRuntime m + | UpperCaseIdentifierInPattern m + | NotUpperCaseConstructor m + | RecursiveUseCheckedAtRuntime (_, _, m) + | LetRecEvaluatedOutOfOrder (_, _, _, m) + | DiagnosticWithText (_, _, m) + | DiagnosticWithSuggestions (_, _, m, _, _) + | SyntaxError (_, m) + | InternalError (_, m) + | InterfaceNotRevealed (_, _, m) + | WrappedError (_, m) + | PatternMatchCompilation.MatchIncomplete (_, _, m) + | PatternMatchCompilation.EnumMatchIncomplete (_, _, m) + | PatternMatchCompilation.RuleNeverMatched m + | ValNotMutable (_, _, m) + | ValNotLocal (_, _, m) + | MissingFields (_, m) + | OverrideInIntrinsicAugmentation m + | IntfImplInIntrinsicAugmentation m + | OverrideInExtrinsicAugmentation m + | IntfImplInExtrinsicAugmentation m + | ValueRestriction (_, _, _, _, _, m) + | LetRecUnsound (_, _, m) + | ObsoleteError (_, m) + | ObsoleteWarning (_, m) + | Experimental (_, m) + | PossibleUnverifiableCode m + | UserCompilerMessage (_, _, m) + | Deprecated (_, m) + | LibraryUseOnly m + | FieldsFromDifferentTypes (_, _, _, m) + | IndeterminateType m + | TyconBadArgs (_, _, _, m) -> Some m + + | FieldNotContained (_, _, _, arf, _, _) -> Some arf.Range + | ValueNotContained (_, _, _, aval, _, _) -> Some aval.Range + | UnionCaseNotContained (_, _, _, aval, _, _) -> Some aval.Id.idRange + | FSharpExceptionNotContained (_, _, aexnc, _, _) -> Some aexnc.Range + + | VarBoundTwice id + | UndefinedName (_, _, id, _) -> Some id.idRange + + | Duplicate (_, _, m) + | NameClash (_, _, _, m, _, _, _) + | UnresolvedOverloading (_, _, _, m) + | UnresolvedConversionOperator (_, _, _, m) + | VirtualAugmentationOnNullValuedType m + | NonVirtualAugmentationOnNullValuedType m + | NonRigidTypar (_, _, _, _, _, m) + | ConstraintSolverTupleDiffLengths (_, _, _, m, _) + | ConstraintSolverInfiniteTypes (_, _, _, _, m, _) + | ConstraintSolverMissingConstraint (_, _, _, m, _) + | ConstraintSolverTypesNotInEqualityRelation (_, _, _, m, _, _) + | ConstraintSolverError (_, m, _) + | ConstraintSolverTypesNotInSubsumptionRelation (_, _, _, m, _) + | SelfRefObjCtor (_, m) -> Some m + + | NotAFunction (_, _, mfun, _) -> Some mfun + + | NotAFunctionButIndexer (_, _, _, mfun, _, _) -> Some mfun + + | IllegalFileNameChar _ -> Some rangeCmdArgs + + | UnresolvedReferenceError (_, m) + | UnresolvedPathReference (_, _, m) + | DeprecatedCommandLineOptionFull (_, m) + | DeprecatedCommandLineOptionForHtmlDoc (_, m) + | DeprecatedCommandLineOptionSuggestAlternative (_, _, m) + | DeprecatedCommandLineOptionNoDescription (_, m) + | InternalCommandLineOption (_, m) + | HashIncludeNotAllowedInNonScript m + | HashReferenceNotAllowedInNonScript m + | HashDirectiveNotAllowedInNonScript m + | FileNameNotResolved (_, _, m) + | LoadedSourceNotFoundIgnoring (_, m) + | MSBuildReferenceResolutionWarning (_, _, m) + | MSBuildReferenceResolutionError (_, _, m) + | AssemblyNotResolved (_, m) + | HashLoadedSourceHasIssues (_, _, _, m) + | HashLoadedScriptConsideredSource m -> Some m + // Strip TargetInvocationException wrappers + | :? System.Reflection.TargetInvocationException as e -> RangeFromException e.InnerException #if !NO_TYPEPROVIDERS - | :? TypeProviderError as e -> e.Range |> Some + | :? TypeProviderError as e -> e.Range |> Some #endif - | _ -> None - - RangeFromException diagnostic.Exception - -let GetDiagnosticNumber(diagnostic: PhasedDiagnostic) = - let rec GetFromException(exn: exn) = - match exn with - // DO NOT CHANGE THESE NUMBERS - | ErrorFromAddingTypeEquation _ -> 1 - | FunctionExpected _ -> 2 - | NotAFunctionButIndexer _ -> 3217 - | NotAFunction _ -> 3 - | FieldNotMutable _ -> 5 - | Recursion _ -> 6 - | InvalidRuntimeCoercion _ -> 7 - | IndeterminateRuntimeCoercion _ -> 8 - | PossibleUnverifiableCode _ -> 9 - | SyntaxError _ -> 10 - // 11 cannot be reused - // 12 cannot be reused - | IndeterminateStaticCoercion _ -> 13 - | StaticCoercionShouldUseBox _ -> 14 - // 15 cannot be reused - | RuntimeCoercionSourceSealed _ -> 16 - | OverrideDoesntOverride _ -> 17 - | UnionPatternsBindDifferentNames _ -> 18 - | UnionCaseWrongArguments _ -> 19 - | UnitTypeExpected _ -> 20 - | UnitTypeExpectedWithEquality _ -> 20 - | UnitTypeExpectedWithPossiblePropertySetter _ -> 20 - | UnitTypeExpectedWithPossibleAssignment _ -> 20 - | RecursiveUseCheckedAtRuntime _ -> 21 - | LetRecEvaluatedOutOfOrder _ -> 22 - | NameClash _ -> 23 - // 24 cannot be reused - | PatternMatchCompilation.MatchIncomplete _ -> 25 - | PatternMatchCompilation.RuleNeverMatched _ -> 26 - | ValNotMutable _ -> 27 - | ValNotLocal _ -> 28 - | MissingFields _ -> 29 - | ValueRestriction _ -> 30 - | LetRecUnsound _ -> 31 - | FieldsFromDifferentTypes _ -> 32 - | TyconBadArgs _ -> 33 - | ValueNotContained _ -> 34 - | Deprecated _ -> 35 - | UnionCaseNotContained _ -> 36 - | Duplicate _ -> 37 - | VarBoundTwice _ -> 38 - | UndefinedName _ -> 39 - | LetRecCheckedAtRuntime _ -> 40 - | UnresolvedOverloading _ -> 41 - | LibraryUseOnly _ -> 42 - | ErrorFromAddingConstraint _ -> 43 - | ObsoleteWarning _ -> 44 - | ReservedKeyword _ -> 46 - | SelfRefObjCtor _ -> 47 - | VirtualAugmentationOnNullValuedType _ -> 48 - | UpperCaseIdentifierInPattern _ -> 49 - | InterfaceNotRevealed _ -> 50 - | UseOfAddressOfOperator _ -> 51 - | DefensiveCopyWarning _ -> 52 - | NotUpperCaseConstructor _ -> 53 - | TypeIsImplicitlyAbstract _ -> 54 - // 55 cannot be reused - | DeprecatedThreadStaticBindingWarning _ -> 56 - | Experimental _ -> 57 - | IndentationProblem _ -> 58 - | CoercionTargetSealed _ -> 59 - | OverrideInIntrinsicAugmentation _ -> 60 - | NonVirtualAugmentationOnNullValuedType _ -> 61 - | UserCompilerMessage (_, n, _) -> n - | FSharpExceptionNotContained _ -> 63 - | NonRigidTypar _ -> 64 - // 65 cannot be reused - | UpcastUnnecessary _ -> 66 - | TypeTestUnnecessary _ -> 67 - | QuotationTranslator.IgnoringPartOfQuotedTermWarning _ -> 68 - | IntfImplInIntrinsicAugmentation _ -> 69 - | NonUniqueInferredAbstractSlot _ -> 70 - | ErrorFromApplyingDefault _ -> 71 - | IndeterminateType _ -> 72 - | InternalError _ -> 73 - | UnresolvedReferenceNoRange _ - | UnresolvedReferenceError _ - | UnresolvedPathReferenceNoRange _ - | UnresolvedPathReference _ -> 74 - | DeprecatedCommandLineOptionFull _ - | DeprecatedCommandLineOptionForHtmlDoc _ - | DeprecatedCommandLineOptionSuggestAlternative _ - | DeprecatedCommandLineOptionNoDescription _ - | InternalCommandLineOption _ -> 75 - | HashIncludeNotAllowedInNonScript _ - | HashReferenceNotAllowedInNonScript _ - | HashDirectiveNotAllowedInNonScript _ -> 76 - | BakedInMemberConstraintName _ -> 77 - | FileNameNotResolved _ -> 78 - | LoadedSourceNotFoundIgnoring _ -> 79 - // 80 cannot be reused - | ParameterlessStructCtor _ -> 81 - | MSBuildReferenceResolutionWarning _ -> 82 - | MSBuildReferenceResolutionError _ -> 83 - | AssemblyNotResolved _ -> 84 - | HashLoadedSourceHasIssues _ -> 85 - | StandardOperatorRedefinitionWarning _ -> 86 - | InvalidInternalsVisibleToAssemblyName _ -> 87 - // 88 cannot be reused - | OverrideInExtrinsicAugmentation _ -> 89 - | IntfImplInExtrinsicAugmentation _ -> 90 - | BadEventTransformation _ -> 91 - | HashLoadedScriptConsideredSource _ -> 92 - | UnresolvedConversionOperator _ -> 93 - // avoid 94-100 for safety - | ObsoleteError _ -> 101 + | _ -> None + + RangeFromException diagnostic.Exception + +let GetDiagnosticNumber (diagnostic: PhasedDiagnostic) = + let rec GetFromException (exn: exn) = + match exn with + // DO NOT CHANGE THESE NUMBERS + | ErrorFromAddingTypeEquation _ -> 1 + | FunctionExpected _ -> 2 + | NotAFunctionButIndexer _ -> 3217 + | NotAFunction _ -> 3 + | FieldNotMutable _ -> 5 + | Recursion _ -> 6 + | InvalidRuntimeCoercion _ -> 7 + | IndeterminateRuntimeCoercion _ -> 8 + | PossibleUnverifiableCode _ -> 9 + | SyntaxError _ -> 10 + // 11 cannot be reused + // 12 cannot be reused + | IndeterminateStaticCoercion _ -> 13 + | StaticCoercionShouldUseBox _ -> 14 + // 15 cannot be reused + | RuntimeCoercionSourceSealed _ -> 16 + | OverrideDoesntOverride _ -> 17 + | UnionPatternsBindDifferentNames _ -> 18 + | UnionCaseWrongArguments _ -> 19 + | UnitTypeExpected _ -> 20 + | UnitTypeExpectedWithEquality _ -> 20 + | UnitTypeExpectedWithPossiblePropertySetter _ -> 20 + | UnitTypeExpectedWithPossibleAssignment _ -> 20 + | RecursiveUseCheckedAtRuntime _ -> 21 + | LetRecEvaluatedOutOfOrder _ -> 22 + | NameClash _ -> 23 + // 24 cannot be reused + | PatternMatchCompilation.MatchIncomplete _ -> 25 + | PatternMatchCompilation.RuleNeverMatched _ -> 26 + | ValNotMutable _ -> 27 + | ValNotLocal _ -> 28 + | MissingFields _ -> 29 + | ValueRestriction _ -> 30 + | LetRecUnsound _ -> 31 + | FieldsFromDifferentTypes _ -> 32 + | TyconBadArgs _ -> 33 + | ValueNotContained _ -> 34 + | Deprecated _ -> 35 + | UnionCaseNotContained _ -> 36 + | Duplicate _ -> 37 + | VarBoundTwice _ -> 38 + | UndefinedName _ -> 39 + | LetRecCheckedAtRuntime _ -> 40 + | UnresolvedOverloading _ -> 41 + | LibraryUseOnly _ -> 42 + | ErrorFromAddingConstraint _ -> 43 + | ObsoleteWarning _ -> 44 + | ReservedKeyword _ -> 46 + | SelfRefObjCtor _ -> 47 + | VirtualAugmentationOnNullValuedType _ -> 48 + | UpperCaseIdentifierInPattern _ -> 49 + | InterfaceNotRevealed _ -> 50 + | UseOfAddressOfOperator _ -> 51 + | DefensiveCopyWarning _ -> 52 + | NotUpperCaseConstructor _ -> 53 + | TypeIsImplicitlyAbstract _ -> 54 + // 55 cannot be reused + | DeprecatedThreadStaticBindingWarning _ -> 56 + | Experimental _ -> 57 + | IndentationProblem _ -> 58 + | CoercionTargetSealed _ -> 59 + | OverrideInIntrinsicAugmentation _ -> 60 + | NonVirtualAugmentationOnNullValuedType _ -> 61 + | UserCompilerMessage (_, n, _) -> n + | FSharpExceptionNotContained _ -> 63 + | NonRigidTypar _ -> 64 + // 65 cannot be reused + | UpcastUnnecessary _ -> 66 + | TypeTestUnnecessary _ -> 67 + | QuotationTranslator.IgnoringPartOfQuotedTermWarning _ -> 68 + | IntfImplInIntrinsicAugmentation _ -> 69 + | NonUniqueInferredAbstractSlot _ -> 70 + | ErrorFromApplyingDefault _ -> 71 + | IndeterminateType _ -> 72 + | InternalError _ -> 73 + | UnresolvedReferenceNoRange _ + | UnresolvedReferenceError _ + | UnresolvedPathReferenceNoRange _ + | UnresolvedPathReference _ -> 74 + | DeprecatedCommandLineOptionFull _ + | DeprecatedCommandLineOptionForHtmlDoc _ + | DeprecatedCommandLineOptionSuggestAlternative _ + | DeprecatedCommandLineOptionNoDescription _ + | InternalCommandLineOption _ -> 75 + | HashIncludeNotAllowedInNonScript _ + | HashReferenceNotAllowedInNonScript _ + | HashDirectiveNotAllowedInNonScript _ -> 76 + | BakedInMemberConstraintName _ -> 77 + | FileNameNotResolved _ -> 78 + | LoadedSourceNotFoundIgnoring _ -> 79 + // 80 cannot be reused + | ParameterlessStructCtor _ -> 81 + | MSBuildReferenceResolutionWarning _ -> 82 + | MSBuildReferenceResolutionError _ -> 83 + | AssemblyNotResolved _ -> 84 + | HashLoadedSourceHasIssues _ -> 85 + | StandardOperatorRedefinitionWarning _ -> 86 + | InvalidInternalsVisibleToAssemblyName _ -> 87 + // 88 cannot be reused + | OverrideInExtrinsicAugmentation _ -> 89 + | IntfImplInExtrinsicAugmentation _ -> 90 + | BadEventTransformation _ -> 91 + | HashLoadedScriptConsideredSource _ -> 92 + | UnresolvedConversionOperator _ -> 93 + // avoid 94-100 for safety + | ObsoleteError _ -> 101 #if !NO_TYPEPROVIDERS - | TypeProviders.ProvidedTypeResolutionNoRange _ - | TypeProviders.ProvidedTypeResolution _ -> 103 + | TypeProviders.ProvidedTypeResolutionNoRange _ + | TypeProviders.ProvidedTypeResolution _ -> 103 #endif - | PatternMatchCompilation.EnumMatchIncomplete _ -> 104 - // DO NOT CHANGE THE NUMBERS + | PatternMatchCompilation.EnumMatchIncomplete _ -> 104 + // DO NOT CHANGE THE NUMBERS - // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as e -> - GetFromException e.InnerException + // Strip TargetInvocationException wrappers + | :? System.Reflection.TargetInvocationException as e -> GetFromException e.InnerException - | WrappedError(e, _) -> GetFromException e + | WrappedError (e, _) -> GetFromException e - | DiagnosticWithText (n, _, _) -> n - | DiagnosticWithSuggestions (n, _, _, _, _) -> n - | Failure _ -> 192 - | IllegalFileNameChar(fileName, invalidChar) -> fst (FSComp.SR.buildUnexpectedFileNameCharacter(fileName, string invalidChar)) + | DiagnosticWithText (n, _, _) -> n + | DiagnosticWithSuggestions (n, _, _, _, _) -> n + | Failure _ -> 192 + | IllegalFileNameChar (fileName, invalidChar) -> fst (FSComp.SR.buildUnexpectedFileNameCharacter (fileName, string invalidChar)) #if !NO_TYPEPROVIDERS - | :? TypeProviderError as e -> e.Number + | :? TypeProviderError as e -> e.Number #endif - | ErrorsFromAddingSubsumptionConstraint (_, _, _, _, _, ContextInfo.DowncastUsedInsteadOfUpcast _, _) -> fst (FSComp.SR.considerUpcast("", "")) - | _ -> 193 + | ErrorsFromAddingSubsumptionConstraint (_, _, _, _, _, ContextInfo.DowncastUsedInsteadOfUpcast _, _) -> + fst (FSComp.SR.considerUpcast ("", "")) + | _ -> 193 + GetFromException diagnostic.Exception let GetWarningLevel diagnostic = @@ -356,10 +350,10 @@ let GetWarningLevel diagnostic = // Level 5 warnings | RecursiveUseCheckedAtRuntime _ | LetRecEvaluatedOutOfOrder _ - | DefensiveCopyWarning _ -> 5 + | DefensiveCopyWarning _ -> 5 - | DiagnosticWithText(n, _, _) - | DiagnosticWithSuggestions(n, _, _, _, _) -> + | DiagnosticWithText (n, _, _) + | DiagnosticWithSuggestions (n, _, _, _, _) -> // 1178, tcNoComparisonNeeded1, "The struct, record or union type '%s' is not structurally comparable because the type parameter %s does not satisfy the 'comparison' constraint..." // 1178, tcNoComparisonNeeded2, "The struct, record or union type '%s' is not structurally comparable because the type '%s' does not satisfy the 'comparison' constraint...." // 1178, tcNoEqualityNeeded1, "The struct, record or union type '%s' does not support structural equality because the type parameter %s does not satisfy the 'equality' constraint..." @@ -369,7 +363,8 @@ let GetWarningLevel diagnostic = | _ -> 2 let IsWarningOrInfoEnabled (diagnostic, severity) n level specificWarnOn = - List.contains n specificWarnOn || + List.contains n specificWarnOn + || // Some specific warnings/informational are never on by default, i.e. unused variable warnings match n with | 1182 -> false // chkUnusedValue - off by default @@ -381,198 +376,208 @@ let IsWarningOrInfoEnabled (diagnostic, severity) n level specificWarnOn = | 3389 -> false // tcBuiltInImplicitConversionUsed - off by default | 3390 -> false // xmlDocBadlyFormed - off by default | 3395 -> false // tcImplicitConversionUsedForMethodArg - off by default - | _ -> - (severity = FSharpDiagnosticSeverity.Info) || - (severity = FSharpDiagnosticSeverity.Warning && level >= GetWarningLevel diagnostic) + | _ -> + (severity = FSharpDiagnosticSeverity.Info) + || (severity = FSharpDiagnosticSeverity.Warning + && level >= GetWarningLevel diagnostic) + +let SplitRelatedDiagnostics (diagnostic: PhasedDiagnostic) : PhasedDiagnostic * PhasedDiagnostic list = + let ToPhased exn = + { + Exception = exn + Phase = diagnostic.Phase + } -let SplitRelatedDiagnostics(diagnostic: PhasedDiagnostic) : PhasedDiagnostic * PhasedDiagnostic list = - let ToPhased exn = {Exception=exn; Phase = diagnostic.Phase} let rec SplitRelatedException exn = - match exn with - | ErrorFromAddingTypeEquation(g, denv, ty1, ty2, exn2, m) -> - let diag2, related = SplitRelatedException exn2 - ErrorFromAddingTypeEquation(g, denv, ty1, ty2, diag2.Exception, m) |> ToPhased, related - | ErrorFromApplyingDefault(g, denv, tp, defaultType, exn2, m) -> - let diag2, related = SplitRelatedException exn2 - ErrorFromApplyingDefault(g, denv, tp, defaultType, diag2.Exception, m) |> ToPhased, related - | ErrorsFromAddingSubsumptionConstraint(g, denv, ty1, ty2, exn2, contextInfo, m) -> - let diag2, related = SplitRelatedException exn2 - ErrorsFromAddingSubsumptionConstraint(g, denv, ty1, ty2, diag2.Exception, contextInfo, m) |> ToPhased, related - | ErrorFromAddingConstraint(x, exn2, m) -> - let diag2, related = SplitRelatedException exn2 - ErrorFromAddingConstraint(x, diag2.Exception, m) |> ToPhased, related - | WrappedError (exn2, m) -> - let diag2, related = SplitRelatedException exn2 - WrappedError(diag2.Exception, m) |> ToPhased, related - // Strip TargetInvocationException wrappers - | :? TargetInvocationException as exn -> - SplitRelatedException exn.InnerException - | _ -> - ToPhased exn, [] - SplitRelatedException diagnostic.Exception + match exn with + | ErrorFromAddingTypeEquation (g, denv, ty1, ty2, exn2, m) -> + let diag2, related = SplitRelatedException exn2 + ErrorFromAddingTypeEquation(g, denv, ty1, ty2, diag2.Exception, m) |> ToPhased, related + | ErrorFromApplyingDefault (g, denv, tp, defaultType, exn2, m) -> + let diag2, related = SplitRelatedException exn2 + + ErrorFromApplyingDefault(g, denv, tp, defaultType, diag2.Exception, m) + |> ToPhased, + related + | ErrorsFromAddingSubsumptionConstraint (g, denv, ty1, ty2, exn2, contextInfo, m) -> + let diag2, related = SplitRelatedException exn2 + + ErrorsFromAddingSubsumptionConstraint(g, denv, ty1, ty2, diag2.Exception, contextInfo, m) + |> ToPhased, + related + | ErrorFromAddingConstraint (x, exn2, m) -> + let diag2, related = SplitRelatedException exn2 + ErrorFromAddingConstraint(x, diag2.Exception, m) |> ToPhased, related + | WrappedError (exn2, m) -> + let diag2, related = SplitRelatedException exn2 + WrappedError(diag2.Exception, m) |> ToPhased, related + // Strip TargetInvocationException wrappers + | :? TargetInvocationException as exn -> SplitRelatedException exn.InnerException + | _ -> ToPhased exn, [] + SplitRelatedException diagnostic.Exception -let DeclareMessage = DeclareResourceString +let Message (name, format) = DeclareResourceString(name, format) do FSComp.SR.RunStartupValidation() -let SeeAlsoE() = DeclareResourceString("SeeAlso", "%s") -let ConstraintSolverTupleDiffLengthsE() = DeclareResourceString("ConstraintSolverTupleDiffLengths", "%d%d") -let ConstraintSolverInfiniteTypesE() = DeclareResourceString("ConstraintSolverInfiniteTypes", "%s%s") -let ConstraintSolverMissingConstraintE() = DeclareResourceString("ConstraintSolverMissingConstraint", "%s") -let ConstraintSolverTypesNotInEqualityRelation1E() = DeclareResourceString("ConstraintSolverTypesNotInEqualityRelation1", "%s%s") -let ConstraintSolverTypesNotInEqualityRelation2E() = DeclareResourceString("ConstraintSolverTypesNotInEqualityRelation2", "%s%s") -let ConstraintSolverTypesNotInSubsumptionRelationE() = DeclareResourceString("ConstraintSolverTypesNotInSubsumptionRelation", "%s%s%s") -let ErrorFromAddingTypeEquation1E() = DeclareResourceString("ErrorFromAddingTypeEquation1", "%s%s%s") -let ErrorFromAddingTypeEquation2E() = DeclareResourceString("ErrorFromAddingTypeEquation2", "%s%s%s") -let ErrorFromApplyingDefault1E() = DeclareResourceString("ErrorFromApplyingDefault1", "%s") -let ErrorFromApplyingDefault2E() = DeclareResourceString("ErrorFromApplyingDefault2", "") -let ErrorsFromAddingSubsumptionConstraintE() = DeclareResourceString("ErrorsFromAddingSubsumptionConstraint", "%s%s%s") -let UpperCaseIdentifierInPatternE() = DeclareResourceString("UpperCaseIdentifierInPattern", "") -let NotUpperCaseConstructorE() = DeclareResourceString("NotUpperCaseConstructor", "") -let FunctionExpectedE() = DeclareResourceString("FunctionExpected", "") -let BakedInMemberConstraintNameE() = DeclareResourceString("BakedInMemberConstraintName", "%s") -let BadEventTransformationE() = DeclareResourceString("BadEventTransformation", "") -let ParameterlessStructCtorE() = DeclareResourceString("ParameterlessStructCtor", "") -let InterfaceNotRevealedE() = DeclareResourceString("InterfaceNotRevealed", "%s") -let TyconBadArgsE() = DeclareResourceString("TyconBadArgs", "%s%d%d") -let IndeterminateTypeE() = DeclareResourceString("IndeterminateType", "") -let NameClash1E() = DeclareResourceString("NameClash1", "%s%s") -let NameClash2E() = DeclareResourceString("NameClash2", "%s%s%s%s%s") -let Duplicate1E() = DeclareResourceString("Duplicate1", "%s") -let Duplicate2E() = DeclareResourceString("Duplicate2", "%s%s") -let UndefinedName2E() = DeclareResourceString("UndefinedName2", "") -let FieldNotMutableE() = DeclareResourceString("FieldNotMutable", "") -let FieldsFromDifferentTypesE() = DeclareResourceString("FieldsFromDifferentTypes", "%s%s") -let VarBoundTwiceE() = DeclareResourceString("VarBoundTwice", "%s") -let RecursionE() = DeclareResourceString("Recursion", "%s%s%s%s") -let InvalidRuntimeCoercionE() = DeclareResourceString("InvalidRuntimeCoercion", "%s%s%s") -let IndeterminateRuntimeCoercionE() = DeclareResourceString("IndeterminateRuntimeCoercion", "%s%s") -let IndeterminateStaticCoercionE() = DeclareResourceString("IndeterminateStaticCoercion", "%s%s") -let StaticCoercionShouldUseBoxE() = DeclareResourceString("StaticCoercionShouldUseBox", "%s%s") -let TypeIsImplicitlyAbstractE() = DeclareResourceString("TypeIsImplicitlyAbstract", "") -let NonRigidTypar1E() = DeclareResourceString("NonRigidTypar1", "%s%s") -let NonRigidTypar2E() = DeclareResourceString("NonRigidTypar2", "%s%s") -let NonRigidTypar3E() = DeclareResourceString("NonRigidTypar3", "%s%s") -let OBlockEndSentenceE() = DeclareResourceString("BlockEndSentence", "") -let UnexpectedEndOfInputE() = DeclareResourceString("UnexpectedEndOfInput", "") -let UnexpectedE() = DeclareResourceString("Unexpected", "%s") -let NONTERM_interactionE() = DeclareResourceString("NONTERM.interaction", "") -let NONTERM_hashDirectiveE() = DeclareResourceString("NONTERM.hashDirective", "") -let NONTERM_fieldDeclE() = DeclareResourceString("NONTERM.fieldDecl", "") -let NONTERM_unionCaseReprE() = DeclareResourceString("NONTERM.unionCaseRepr", "") -let NONTERM_localBindingE() = DeclareResourceString("NONTERM.localBinding", "") -let NONTERM_hardwhiteLetBindingsE() = DeclareResourceString("NONTERM.hardwhiteLetBindings", "") -let NONTERM_classDefnMemberE() = DeclareResourceString("NONTERM.classDefnMember", "") -let NONTERM_defnBindingsE() = DeclareResourceString("NONTERM.defnBindings", "") -let NONTERM_classMemberSpfnE() = DeclareResourceString("NONTERM.classMemberSpfn", "") -let NONTERM_valSpfnE() = DeclareResourceString("NONTERM.valSpfn", "") -let NONTERM_tyconSpfnE() = DeclareResourceString("NONTERM.tyconSpfn", "") -let NONTERM_anonLambdaExprE() = DeclareResourceString("NONTERM.anonLambdaExpr", "") -let NONTERM_attrUnionCaseDeclE() = DeclareResourceString("NONTERM.attrUnionCaseDecl", "") -let NONTERM_cPrototypeE() = DeclareResourceString("NONTERM.cPrototype", "") -let NONTERM_objectImplementationMembersE() = DeclareResourceString("NONTERM.objectImplementationMembers", "") -let NONTERM_ifExprCasesE() = DeclareResourceString("NONTERM.ifExprCases", "") -let NONTERM_openDeclE() = DeclareResourceString("NONTERM.openDecl", "") -let NONTERM_fileModuleSpecE() = DeclareResourceString("NONTERM.fileModuleSpec", "") -let NONTERM_patternClausesE() = DeclareResourceString("NONTERM.patternClauses", "") -let NONTERM_beginEndExprE() = DeclareResourceString("NONTERM.beginEndExpr", "") -let NONTERM_recdExprE() = DeclareResourceString("NONTERM.recdExpr", "") -let NONTERM_tyconDefnE() = DeclareResourceString("NONTERM.tyconDefn", "") -let NONTERM_exconCoreE() = DeclareResourceString("NONTERM.exconCore", "") -let NONTERM_typeNameInfoE() = DeclareResourceString("NONTERM.typeNameInfo", "") -let NONTERM_attributeListE() = DeclareResourceString("NONTERM.attributeList", "") -let NONTERM_quoteExprE() = DeclareResourceString("NONTERM.quoteExpr", "") -let NONTERM_typeConstraintE() = DeclareResourceString("NONTERM.typeConstraint", "") -let NONTERM_Category_ImplementationFileE() = DeclareResourceString("NONTERM.Category.ImplementationFile", "") -let NONTERM_Category_DefinitionE() = DeclareResourceString("NONTERM.Category.Definition", "") -let NONTERM_Category_SignatureFileE() = DeclareResourceString("NONTERM.Category.SignatureFile", "") -let NONTERM_Category_PatternE() = DeclareResourceString("NONTERM.Category.Pattern", "") -let NONTERM_Category_ExprE() = DeclareResourceString("NONTERM.Category.Expr", "") -let NONTERM_Category_TypeE() = DeclareResourceString("NONTERM.Category.Type", "") -let NONTERM_typeArgsActualE() = DeclareResourceString("NONTERM.typeArgsActual", "") -let TokenName1E() = DeclareResourceString("TokenName1", "%s") -let TokenName1TokenName2E() = DeclareResourceString("TokenName1TokenName2", "%s%s") -let TokenName1TokenName2TokenName3E() = DeclareResourceString("TokenName1TokenName2TokenName3", "%s%s%s") -let RuntimeCoercionSourceSealed1E() = DeclareResourceString("RuntimeCoercionSourceSealed1", "%s") -let RuntimeCoercionSourceSealed2E() = DeclareResourceString("RuntimeCoercionSourceSealed2", "%s") -let CoercionTargetSealedE() = DeclareResourceString("CoercionTargetSealed", "%s") -let UpcastUnnecessaryE() = DeclareResourceString("UpcastUnnecessary", "") -let TypeTestUnnecessaryE() = DeclareResourceString("TypeTestUnnecessary", "") -let OverrideDoesntOverride1E() = DeclareResourceString("OverrideDoesntOverride1", "%s") -let OverrideDoesntOverride2E() = DeclareResourceString("OverrideDoesntOverride2", "%s") -let OverrideDoesntOverride3E() = DeclareResourceString("OverrideDoesntOverride3", "%s") -let OverrideDoesntOverride4E() = DeclareResourceString("OverrideDoesntOverride4", "%s") -let UnionCaseWrongArgumentsE() = DeclareResourceString("UnionCaseWrongArguments", "%d%d") -let UnionPatternsBindDifferentNamesE() = DeclareResourceString("UnionPatternsBindDifferentNames", "") -let RequiredButNotSpecifiedE() = DeclareResourceString("RequiredButNotSpecified", "%s%s%s") -let UseOfAddressOfOperatorE() = DeclareResourceString("UseOfAddressOfOperator", "") -let DefensiveCopyWarningE() = DeclareResourceString("DefensiveCopyWarning", "%s") -let DeprecatedThreadStaticBindingWarningE() = DeclareResourceString("DeprecatedThreadStaticBindingWarning", "") -let FunctionValueUnexpectedE() = DeclareResourceString("FunctionValueUnexpected", "%s") -let UnitTypeExpectedE() = DeclareResourceString("UnitTypeExpected", "%s") -let UnitTypeExpectedWithEqualityE() = DeclareResourceString("UnitTypeExpectedWithEquality", "%s") -let UnitTypeExpectedWithPossiblePropertySetterE() = DeclareResourceString("UnitTypeExpectedWithPossiblePropertySetter", "%s%s%s") -let UnitTypeExpectedWithPossibleAssignmentE() = DeclareResourceString("UnitTypeExpectedWithPossibleAssignment", "%s%s") -let UnitTypeExpectedWithPossibleAssignmentToMutableE() = DeclareResourceString("UnitTypeExpectedWithPossibleAssignmentToMutable", "%s%s") -let RecursiveUseCheckedAtRuntimeE() = DeclareResourceString("RecursiveUseCheckedAtRuntime", "") -let LetRecUnsound1E() = DeclareResourceString("LetRecUnsound1", "%s") -let LetRecUnsound2E() = DeclareResourceString("LetRecUnsound2", "%s%s") -let LetRecUnsoundInnerE() = DeclareResourceString("LetRecUnsoundInner", "%s") -let LetRecEvaluatedOutOfOrderE() = DeclareResourceString("LetRecEvaluatedOutOfOrder", "") -let LetRecCheckedAtRuntimeE() = DeclareResourceString("LetRecCheckedAtRuntime", "") -let SelfRefObjCtor1E() = DeclareResourceString("SelfRefObjCtor1", "") -let SelfRefObjCtor2E() = DeclareResourceString("SelfRefObjCtor2", "") -let VirtualAugmentationOnNullValuedTypeE() = DeclareResourceString("VirtualAugmentationOnNullValuedType", "") -let NonVirtualAugmentationOnNullValuedTypeE() = DeclareResourceString("NonVirtualAugmentationOnNullValuedType", "") -let NonUniqueInferredAbstractSlot1E() = DeclareResourceString("NonUniqueInferredAbstractSlot1", "%s") -let NonUniqueInferredAbstractSlot2E() = DeclareResourceString("NonUniqueInferredAbstractSlot2", "") -let NonUniqueInferredAbstractSlot3E() = DeclareResourceString("NonUniqueInferredAbstractSlot3", "%s%s") -let NonUniqueInferredAbstractSlot4E() = DeclareResourceString("NonUniqueInferredAbstractSlot4", "") -let Failure3E() = DeclareResourceString("Failure3", "%s") -let Failure4E() = DeclareResourceString("Failure4", "%s") -let MatchIncomplete1E() = DeclareResourceString("MatchIncomplete1", "") -let MatchIncomplete2E() = DeclareResourceString("MatchIncomplete2", "%s") -let MatchIncomplete3E() = DeclareResourceString("MatchIncomplete3", "%s") -let MatchIncomplete4E() = DeclareResourceString("MatchIncomplete4", "") -let RuleNeverMatchedE() = DeclareResourceString("RuleNeverMatched", "") -let EnumMatchIncomplete1E() = DeclareResourceString("EnumMatchIncomplete1", "") -let ValNotMutableE() = DeclareResourceString("ValNotMutable", "%s") -let ValNotLocalE() = DeclareResourceString("ValNotLocal", "") -let Obsolete1E() = DeclareResourceString("Obsolete1", "") -let Obsolete2E() = DeclareResourceString("Obsolete2", "%s") -let ExperimentalE() = DeclareResourceString("Experimental", "%s") -let PossibleUnverifiableCodeE() = DeclareResourceString("PossibleUnverifiableCode", "") -let DeprecatedE() = DeclareResourceString("Deprecated", "%s") -let LibraryUseOnlyE() = DeclareResourceString("LibraryUseOnly", "") -let MissingFieldsE() = DeclareResourceString("MissingFields", "%s") -let ValueRestriction1E() = DeclareResourceString("ValueRestriction1", "%s%s%s") -let ValueRestriction2E() = DeclareResourceString("ValueRestriction2", "%s%s%s") -let ValueRestriction3E() = DeclareResourceString("ValueRestriction3", "%s") -let ValueRestriction4E() = DeclareResourceString("ValueRestriction4", "%s%s%s") -let ValueRestriction5E() = DeclareResourceString("ValueRestriction5", "%s%s%s") -let RecoverableParseErrorE() = DeclareResourceString("RecoverableParseError", "") -let ReservedKeywordE() = DeclareResourceString("ReservedKeyword", "%s") -let IndentationProblemE() = DeclareResourceString("IndentationProblem", "%s") -let OverrideInIntrinsicAugmentationE() = DeclareResourceString("OverrideInIntrinsicAugmentation", "") -let OverrideInExtrinsicAugmentationE() = DeclareResourceString("OverrideInExtrinsicAugmentation", "") -let IntfImplInIntrinsicAugmentationE() = DeclareResourceString("IntfImplInIntrinsicAugmentation", "") -let IntfImplInExtrinsicAugmentationE() = DeclareResourceString("IntfImplInExtrinsicAugmentation", "") -let UnresolvedReferenceNoRangeE() = DeclareResourceString("UnresolvedReferenceNoRange", "%s") -let UnresolvedPathReferenceNoRangeE() = DeclareResourceString("UnresolvedPathReferenceNoRange", "%s%s") -let HashIncludeNotAllowedInNonScriptE() = DeclareResourceString("HashIncludeNotAllowedInNonScript", "") -let HashReferenceNotAllowedInNonScriptE() = DeclareResourceString("HashReferenceNotAllowedInNonScript", "") -let HashDirectiveNotAllowedInNonScriptE() = DeclareResourceString("HashDirectiveNotAllowedInNonScript", "") -let FileNameNotResolvedE() = DeclareResourceString("FileNameNotResolved", "%s%s") -let AssemblyNotResolvedE() = DeclareResourceString("AssemblyNotResolved", "%s") -let HashLoadedSourceHasIssues0E() = DeclareResourceString("HashLoadedSourceHasIssues0", "") -let HashLoadedSourceHasIssues1E() = DeclareResourceString("HashLoadedSourceHasIssues1", "") -let HashLoadedSourceHasIssues2E() = DeclareResourceString("HashLoadedSourceHasIssues2", "") -let HashLoadedScriptConsideredSourceE() = DeclareResourceString("HashLoadedScriptConsideredSource", "") -let InvalidInternalsVisibleToAssemblyName1E() = DeclareResourceString("InvalidInternalsVisibleToAssemblyName1", "%s%s") -let InvalidInternalsVisibleToAssemblyName2E() = DeclareResourceString("InvalidInternalsVisibleToAssemblyName2", "%s") -let LoadedSourceNotFoundIgnoringE() = DeclareResourceString("LoadedSourceNotFoundIgnoring", "%s") -let MSBuildReferenceResolutionErrorE() = DeclareResourceString("MSBuildReferenceResolutionError", "%s%s") -let TargetInvocationExceptionWrapperE() = DeclareResourceString("TargetInvocationExceptionWrapper", "%s") +let SeeAlsoE () = Message("SeeAlso", "%s") +let ConstraintSolverTupleDiffLengthsE () = Message("ConstraintSolverTupleDiffLengths", "%d%d") +let ConstraintSolverInfiniteTypesE () = Message("ConstraintSolverInfiniteTypes", "%s%s") +let ConstraintSolverMissingConstraintE () = Message("ConstraintSolverMissingConstraint", "%s") +let ConstraintSolverTypesNotInEqualityRelation1E () = Message("ConstraintSolverTypesNotInEqualityRelation1", "%s%s") +let ConstraintSolverTypesNotInEqualityRelation2E () = Message("ConstraintSolverTypesNotInEqualityRelation2", "%s%s") +let ConstraintSolverTypesNotInSubsumptionRelationE () = Message("ConstraintSolverTypesNotInSubsumptionRelation", "%s%s%s") +let ErrorFromAddingTypeEquation1E () = Message("ErrorFromAddingTypeEquation1", "%s%s%s") +let ErrorFromAddingTypeEquation2E () = Message("ErrorFromAddingTypeEquation2", "%s%s%s") +let ErrorFromApplyingDefault1E () = Message("ErrorFromApplyingDefault1", "%s") +let ErrorFromApplyingDefault2E () = Message("ErrorFromApplyingDefault2", "") +let ErrorsFromAddingSubsumptionConstraintE () = Message("ErrorsFromAddingSubsumptionConstraint", "%s%s%s") +let UpperCaseIdentifierInPatternE () = Message("UpperCaseIdentifierInPattern", "") +let NotUpperCaseConstructorE () = Message("NotUpperCaseConstructor", "") +let FunctionExpectedE () = Message("FunctionExpected", "") +let BakedInMemberConstraintNameE () = Message("BakedInMemberConstraintName", "%s") +let BadEventTransformationE () = Message("BadEventTransformation", "") +let ParameterlessStructCtorE () = Message("ParameterlessStructCtor", "") +let InterfaceNotRevealedE () = Message("InterfaceNotRevealed", "%s") +let TyconBadArgsE () = Message("TyconBadArgs", "%s%d%d") +let IndeterminateTypeE () = Message("IndeterminateType", "") +let NameClash1E () = Message("NameClash1", "%s%s") +let NameClash2E () = Message("NameClash2", "%s%s%s%s%s") +let Duplicate1E () = Message("Duplicate1", "%s") +let Duplicate2E () = Message("Duplicate2", "%s%s") +let UndefinedName2E () = Message("UndefinedName2", "") +let FieldNotMutableE () = Message("FieldNotMutable", "") +let FieldsFromDifferentTypesE () = Message("FieldsFromDifferentTypes", "%s%s") +let VarBoundTwiceE () = Message("VarBoundTwice", "%s") +let RecursionE () = Message("Recursion", "%s%s%s%s") +let InvalidRuntimeCoercionE () = Message("InvalidRuntimeCoercion", "%s%s%s") +let IndeterminateRuntimeCoercionE () = Message("IndeterminateRuntimeCoercion", "%s%s") +let IndeterminateStaticCoercionE () = Message("IndeterminateStaticCoercion", "%s%s") +let StaticCoercionShouldUseBoxE () = Message("StaticCoercionShouldUseBox", "%s%s") +let TypeIsImplicitlyAbstractE () = Message("TypeIsImplicitlyAbstract", "") +let NonRigidTypar1E () = Message("NonRigidTypar1", "%s%s") +let NonRigidTypar2E () = Message("NonRigidTypar2", "%s%s") +let NonRigidTypar3E () = Message("NonRigidTypar3", "%s%s") +let OBlockEndSentenceE () = Message("BlockEndSentence", "") +let UnexpectedEndOfInputE () = Message("UnexpectedEndOfInput", "") +let UnexpectedE () = Message("Unexpected", "%s") +let NONTERM_interactionE () = Message("NONTERM.interaction", "") +let NONTERM_hashDirectiveE () = Message("NONTERM.hashDirective", "") +let NONTERM_fieldDeclE () = Message("NONTERM.fieldDecl", "") +let NONTERM_unionCaseReprE () = Message("NONTERM.unionCaseRepr", "") +let NONTERM_localBindingE () = Message("NONTERM.localBinding", "") +let NONTERM_hardwhiteLetBindingsE () = Message("NONTERM.hardwhiteLetBindings", "") +let NONTERM_classDefnMemberE () = Message("NONTERM.classDefnMember", "") +let NONTERM_defnBindingsE () = Message("NONTERM.defnBindings", "") +let NONTERM_classMemberSpfnE () = Message("NONTERM.classMemberSpfn", "") +let NONTERM_valSpfnE () = Message("NONTERM.valSpfn", "") +let NONTERM_tyconSpfnE () = Message("NONTERM.tyconSpfn", "") +let NONTERM_anonLambdaExprE () = Message("NONTERM.anonLambdaExpr", "") +let NONTERM_attrUnionCaseDeclE () = Message("NONTERM.attrUnionCaseDecl", "") +let NONTERM_cPrototypeE () = Message("NONTERM.cPrototype", "") +let NONTERM_objectImplementationMembersE () = Message("NONTERM.objectImplementationMembers", "") +let NONTERM_ifExprCasesE () = Message("NONTERM.ifExprCases", "") +let NONTERM_openDeclE () = Message("NONTERM.openDecl", "") +let NONTERM_fileModuleSpecE () = Message("NONTERM.fileModuleSpec", "") +let NONTERM_patternClausesE () = Message("NONTERM.patternClauses", "") +let NONTERM_beginEndExprE () = Message("NONTERM.beginEndExpr", "") +let NONTERM_recdExprE () = Message("NONTERM.recdExpr", "") +let NONTERM_tyconDefnE () = Message("NONTERM.tyconDefn", "") +let NONTERM_exconCoreE () = Message("NONTERM.exconCore", "") +let NONTERM_typeNameInfoE () = Message("NONTERM.typeNameInfo", "") +let NONTERM_attributeListE () = Message("NONTERM.attributeList", "") +let NONTERM_quoteExprE () = Message("NONTERM.quoteExpr", "") +let NONTERM_typeConstraintE () = Message("NONTERM.typeConstraint", "") +let NONTERM_Category_ImplementationFileE () = Message("NONTERM.Category.ImplementationFile", "") +let NONTERM_Category_DefinitionE () = Message("NONTERM.Category.Definition", "") +let NONTERM_Category_SignatureFileE () = Message("NONTERM.Category.SignatureFile", "") +let NONTERM_Category_PatternE () = Message("NONTERM.Category.Pattern", "") +let NONTERM_Category_ExprE () = Message("NONTERM.Category.Expr", "") +let NONTERM_Category_TypeE () = Message("NONTERM.Category.Type", "") +let NONTERM_typeArgsActualE () = Message("NONTERM.typeArgsActual", "") +let TokenName1E () = Message("TokenName1", "%s") +let TokenName1TokenName2E () = Message("TokenName1TokenName2", "%s%s") +let TokenName1TokenName2TokenName3E () = Message("TokenName1TokenName2TokenName3", "%s%s%s") +let RuntimeCoercionSourceSealed1E () = Message("RuntimeCoercionSourceSealed1", "%s") +let RuntimeCoercionSourceSealed2E () = Message("RuntimeCoercionSourceSealed2", "%s") +let CoercionTargetSealedE () = Message("CoercionTargetSealed", "%s") +let UpcastUnnecessaryE () = Message("UpcastUnnecessary", "") +let TypeTestUnnecessaryE () = Message("TypeTestUnnecessary", "") +let OverrideDoesntOverride1E () = Message("OverrideDoesntOverride1", "%s") +let OverrideDoesntOverride2E () = Message("OverrideDoesntOverride2", "%s") +let OverrideDoesntOverride3E () = Message("OverrideDoesntOverride3", "%s") +let OverrideDoesntOverride4E () = Message("OverrideDoesntOverride4", "%s") +let UnionCaseWrongArgumentsE () = Message("UnionCaseWrongArguments", "%d%d") +let UnionPatternsBindDifferentNamesE () = Message("UnionPatternsBindDifferentNames", "") +let RequiredButNotSpecifiedE () = Message("RequiredButNotSpecified", "%s%s%s") +let UseOfAddressOfOperatorE () = Message("UseOfAddressOfOperator", "") +let DefensiveCopyWarningE () = Message("DefensiveCopyWarning", "%s") +let DeprecatedThreadStaticBindingWarningE () = Message("DeprecatedThreadStaticBindingWarning", "") +let FunctionValueUnexpectedE () = Message("FunctionValueUnexpected", "%s") +let UnitTypeExpectedE () = Message("UnitTypeExpected", "%s") +let UnitTypeExpectedWithEqualityE () = Message("UnitTypeExpectedWithEquality", "%s") +let UnitTypeExpectedWithPossiblePropertySetterE () = Message("UnitTypeExpectedWithPossiblePropertySetter", "%s%s%s") +let UnitTypeExpectedWithPossibleAssignmentE () = Message("UnitTypeExpectedWithPossibleAssignment", "%s%s") +let UnitTypeExpectedWithPossibleAssignmentToMutableE () = Message("UnitTypeExpectedWithPossibleAssignmentToMutable", "%s%s") +let RecursiveUseCheckedAtRuntimeE () = Message("RecursiveUseCheckedAtRuntime", "") +let LetRecUnsound1E () = Message("LetRecUnsound1", "%s") +let LetRecUnsound2E () = Message("LetRecUnsound2", "%s%s") +let LetRecUnsoundInnerE () = Message("LetRecUnsoundInner", "%s") +let LetRecEvaluatedOutOfOrderE () = Message("LetRecEvaluatedOutOfOrder", "") +let LetRecCheckedAtRuntimeE () = Message("LetRecCheckedAtRuntime", "") +let SelfRefObjCtor1E () = Message("SelfRefObjCtor1", "") +let SelfRefObjCtor2E () = Message("SelfRefObjCtor2", "") +let VirtualAugmentationOnNullValuedTypeE () = Message("VirtualAugmentationOnNullValuedType", "") +let NonVirtualAugmentationOnNullValuedTypeE () = Message("NonVirtualAugmentationOnNullValuedType", "") +let NonUniqueInferredAbstractSlot1E () = Message("NonUniqueInferredAbstractSlot1", "%s") +let NonUniqueInferredAbstractSlot2E () = Message("NonUniqueInferredAbstractSlot2", "") +let NonUniqueInferredAbstractSlot3E () = Message("NonUniqueInferredAbstractSlot3", "%s%s") +let NonUniqueInferredAbstractSlot4E () = Message("NonUniqueInferredAbstractSlot4", "") +let Failure3E () = Message("Failure3", "%s") +let Failure4E () = Message("Failure4", "%s") +let MatchIncomplete1E () = Message("MatchIncomplete1", "") +let MatchIncomplete2E () = Message("MatchIncomplete2", "%s") +let MatchIncomplete3E () = Message("MatchIncomplete3", "%s") +let MatchIncomplete4E () = Message("MatchIncomplete4", "") +let RuleNeverMatchedE () = Message("RuleNeverMatched", "") +let EnumMatchIncomplete1E () = Message("EnumMatchIncomplete1", "") +let ValNotMutableE () = Message("ValNotMutable", "%s") +let ValNotLocalE () = Message("ValNotLocal", "") +let Obsolete1E () = Message("Obsolete1", "") +let Obsolete2E () = Message("Obsolete2", "%s") +let ExperimentalE () = Message("Experimental", "%s") +let PossibleUnverifiableCodeE () = Message("PossibleUnverifiableCode", "") +let DeprecatedE () = Message("Deprecated", "%s") +let LibraryUseOnlyE () = Message("LibraryUseOnly", "") +let MissingFieldsE () = Message("MissingFields", "%s") +let ValueRestriction1E () = Message("ValueRestriction1", "%s%s%s") +let ValueRestriction2E () = Message("ValueRestriction2", "%s%s%s") +let ValueRestriction3E () = Message("ValueRestriction3", "%s") +let ValueRestriction4E () = Message("ValueRestriction4", "%s%s%s") +let ValueRestriction5E () = Message("ValueRestriction5", "%s%s%s") +let RecoverableParseErrorE () = Message("RecoverableParseError", "") +let ReservedKeywordE () = Message("ReservedKeyword", "%s") +let IndentationProblemE () = Message("IndentationProblem", "%s") +let OverrideInIntrinsicAugmentationE () = Message("OverrideInIntrinsicAugmentation", "") +let OverrideInExtrinsicAugmentationE () = Message("OverrideInExtrinsicAugmentation", "") +let IntfImplInIntrinsicAugmentationE () = Message("IntfImplInIntrinsicAugmentation", "") +let IntfImplInExtrinsicAugmentationE () = Message("IntfImplInExtrinsicAugmentation", "") +let UnresolvedReferenceNoRangeE () = Message("UnresolvedReferenceNoRange", "%s") +let UnresolvedPathReferenceNoRangeE () = Message("UnresolvedPathReferenceNoRange", "%s%s") +let HashIncludeNotAllowedInNonScriptE () = Message("HashIncludeNotAllowedInNonScript", "") +let HashReferenceNotAllowedInNonScriptE () = Message("HashReferenceNotAllowedInNonScript", "") +let HashDirectiveNotAllowedInNonScriptE () = Message("HashDirectiveNotAllowedInNonScript", "") +let FileNameNotResolvedE () = Message("FileNameNotResolved", "%s%s") +let AssemblyNotResolvedE () = Message("AssemblyNotResolved", "%s") +let HashLoadedSourceHasIssues0E () = Message("HashLoadedSourceHasIssues0", "") +let HashLoadedSourceHasIssues1E () = Message("HashLoadedSourceHasIssues1", "") +let HashLoadedSourceHasIssues2E () = Message("HashLoadedSourceHasIssues2", "") +let HashLoadedScriptConsideredSourceE () = Message("HashLoadedScriptConsideredSource", "") +let InvalidInternalsVisibleToAssemblyName1E () = Message("InvalidInternalsVisibleToAssemblyName1", "%s%s") +let InvalidInternalsVisibleToAssemblyName2E () = Message("InvalidInternalsVisibleToAssemblyName2", "%s") +let LoadedSourceNotFoundIgnoringE () = Message("LoadedSourceNotFoundIgnoring", "%s") +let MSBuildReferenceResolutionErrorE () = Message("MSBuildReferenceResolutionError", "%s%s") +let TargetInvocationExceptionWrapperE () = Message("TargetInvocationExceptionWrapper", "%s") #if DEBUG let mutable showParserStackOnParseError = false @@ -580,744 +585,873 @@ let mutable showParserStackOnParseError = false let getErrorString key = SR.GetString key -let (|InvalidArgument|_|) (exn: exn) = match exn with :? ArgumentException as e -> Some e.Message | _ -> None +let (|InvalidArgument|_|) (exn: exn) = + match exn with + | :? ArgumentException as e -> Some e.Message + | _ -> None let OutputPhasedErrorR (os: StringBuilder) (diagnostic: PhasedDiagnostic) (canSuggestNames: bool) = let suggestNames suggestionsF idText = if canSuggestNames then let buffer = DiagnosticResolutionHints.SuggestionBuffer idText + if not buffer.Disabled then - suggestionsF buffer.Add - if not buffer.IsEmpty then - os.AppendString " " - os.AppendString(FSComp.SR.undefinedNameSuggestionsIntro()) - for value in buffer do - os.AppendLine() |> ignore - os.AppendString " " - os.AppendString(DecompileOpName value) + suggestionsF buffer.Add + + if not buffer.IsEmpty then + os.AppendString " " + os.AppendString(FSComp.SR.undefinedNameSuggestionsIntro ()) + + for value in buffer do + os.AppendLine() |> ignore + os.AppendString " " + os.AppendString(DecompileOpName value) let rec OutputExceptionR (os: StringBuilder) error = - match error with - | ConstraintSolverTupleDiffLengths(_, tl1, tl2, m, m2) -> - os.AppendString(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m)) - - | ConstraintSolverInfiniteTypes(denv, contextInfo, ty1, ty2, m, m2) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(ConstraintSolverInfiniteTypesE().Format ty1 ty2) - - match contextInfo with - | ContextInfo.ReturnInComputationExpression -> - os.AppendString(" " + FSComp.SR.returnUsedInsteadOfReturnBang()) - | ContextInfo.YieldInComputationExpression -> - os.AppendString(" " + FSComp.SR.yieldUsedInsteadOfYieldBang()) - | _ -> () - - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m)) - - | ConstraintSolverMissingConstraint(denv, tpr, tpc, m, m2) -> - os.AppendString(ConstraintSolverMissingConstraintE().Format (NicePrint.stringOfTyparConstraint denv (tpr, tpc))) - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m)) - - | ConstraintSolverTypesNotInEqualityRelation(denv, (TType_measure _ as ty1), (TType_measure _ as ty2), m, m2, _) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - - os.AppendString(ConstraintSolverTypesNotInEqualityRelation1E().Format ty1 ty2 ) - - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m)) - - | ConstraintSolverTypesNotInEqualityRelation(denv, ty1, ty2, m, m2, contextInfo) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - - match contextInfo with - | ContextInfo.IfExpression range when equals range m -> os.AppendString(FSComp.SR.ifExpression(ty1, ty2)) - | ContextInfo.CollectionElement (isArray, range) when equals range m -> - if isArray then - os.AppendString(FSComp.SR.arrayElementHasWrongType(ty1, ty2)) - else - os.AppendString(FSComp.SR.listElementHasWrongType(ty1, ty2)) - | ContextInfo.OmittedElseBranch range when equals range m -> os.AppendString(FSComp.SR.missingElseBranch(ty2)) - | ContextInfo.ElseBranchResult range when equals range m -> os.AppendString(FSComp.SR.elseBranchHasWrongType(ty1, ty2)) - | ContextInfo.FollowingPatternMatchClause range when equals range m -> os.AppendString(FSComp.SR.followingPatternMatchClauseHasWrongType(ty1, ty2)) - | ContextInfo.PatternMatchGuard range when equals range m -> os.AppendString(FSComp.SR.patternMatchGuardIsNotBool(ty2)) - | _ -> os.AppendString(ConstraintSolverTypesNotInEqualityRelation2E().Format ty1 ty2) - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m)) - - | ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, m, m2) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(ConstraintSolverTypesNotInSubsumptionRelationE().Format ty2 ty1 cxs) - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m2)) - - | ConstraintSolverError(msg, m, m2) -> - os.AppendString msg - if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format (stringOfRange m2)) - - | ErrorFromAddingTypeEquation(g, denv, ty1, ty2, ConstraintSolverTypesNotInEqualityRelation(_, ty1b, ty2b, m, _, contextInfo), _) - when typeEquiv g ty1 ty1b - && typeEquiv g ty2 ty2b -> - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - match contextInfo with - | ContextInfo.IfExpression range when equals range m -> - os.AppendString(FSComp.SR.ifExpression(ty1, ty2)) - - | ContextInfo.CollectionElement (isArray, range) when equals range m -> - if isArray then - os.AppendString(FSComp.SR.arrayElementHasWrongType(ty1, ty2)) - else - os.AppendString(FSComp.SR.listElementHasWrongType(ty1, ty2)) - - | ContextInfo.OmittedElseBranch range when equals range m -> - os.AppendString(FSComp.SR.missingElseBranch(ty2)) - - | ContextInfo.ElseBranchResult range when equals range m -> - os.AppendString(FSComp.SR.elseBranchHasWrongType(ty1, ty2)) - - | ContextInfo.FollowingPatternMatchClause range when equals range m -> - os.AppendString(FSComp.SR.followingPatternMatchClauseHasWrongType(ty1, ty2)) - - | ContextInfo.PatternMatchGuard range when equals range m -> - os.AppendString(FSComp.SR.patternMatchGuardIsNotBool(ty2)) - - | ContextInfo.TupleInRecordFields -> - os.AppendString(ErrorFromAddingTypeEquation1E().Format ty2 ty1 tpcs) - os.AppendString(Environment.NewLine + FSComp.SR.commaInsteadOfSemicolonInRecord()) - - | _ when ty2 = "bool" && ty1.EndsWithOrdinal(" ref") -> - os.AppendString(ErrorFromAddingTypeEquation1E().Format ty2 ty1 tpcs) - os.AppendString(Environment.NewLine + FSComp.SR.derefInsteadOfNot()) - - | _ -> - os.AppendString(ErrorFromAddingTypeEquation1E().Format ty2 ty1 tpcs) - - | ErrorFromAddingTypeEquation(_, _, _, _, (ConstraintSolverTypesNotInEqualityRelation (_, _, _, _, _, contextInfo) as e), _) - when (match contextInfo with ContextInfo.NoContext -> false | _ -> true) -> - OutputExceptionR os e - - | ErrorFromAddingTypeEquation(_, _, _, _, (ConstraintSolverTypesNotInSubsumptionRelation _ | ConstraintSolverError _ as e), _) -> - OutputExceptionR os e - - | ErrorFromAddingTypeEquation(g, denv, ty1, ty2, e, _) -> - if not (typeEquiv g ty1 ty2) then - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - if ty1<>ty2 + tpcs then os.AppendString(ErrorFromAddingTypeEquation2E().Format ty1 ty2 tpcs) - - OutputExceptionR os e - - | ErrorFromApplyingDefault(_, denv, _, defaultType, e, _) -> - let defaultType = NicePrint.minimalStringOfType denv defaultType - os.AppendString(ErrorFromApplyingDefault1E().Format defaultType) - OutputExceptionR os e - os.AppendString(ErrorFromApplyingDefault2E().Format) - - | ErrorsFromAddingSubsumptionConstraint(g, denv, ty1, ty2, e, contextInfo, _) -> - match contextInfo with - | ContextInfo.DowncastUsedInsteadOfUpcast isOperator -> - let ty1, ty2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - if isOperator then - os.AppendString(FSComp.SR.considerUpcastOperator(ty1, ty2) |> snd) - else - os.AppendString(FSComp.SR.considerUpcast(ty1, ty2) |> snd) - | _ -> - if not (typeEquiv g ty1 ty2) then - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - if ty1 <> (ty2 + tpcs) then - os.AppendString(ErrorsFromAddingSubsumptionConstraintE().Format ty2 ty1 tpcs) - else - OutputExceptionR os e - else - OutputExceptionR os e - - | UpperCaseIdentifierInPattern _ -> - os.AppendString(UpperCaseIdentifierInPatternE().Format) - - | NotUpperCaseConstructor _ -> - os.AppendString(NotUpperCaseConstructorE().Format) - - | ErrorFromAddingConstraint(_, e, _) -> - OutputExceptionR os e + match error with + | ConstraintSolverTupleDiffLengths (_, tl1, tl2, m, m2) -> + os.AppendString(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m)) + + | ConstraintSolverInfiniteTypes (denv, contextInfo, ty1, ty2, m, m2) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(ConstraintSolverInfiniteTypesE().Format ty1 ty2) + + match contextInfo with + | ContextInfo.ReturnInComputationExpression -> os.AppendString(" " + FSComp.SR.returnUsedInsteadOfReturnBang ()) + | ContextInfo.YieldInComputationExpression -> os.AppendString(" " + FSComp.SR.yieldUsedInsteadOfYieldBang ()) + | _ -> () + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m)) + + | ConstraintSolverMissingConstraint (denv, tpr, tpc, m, m2) -> + os.AppendString( + ConstraintSolverMissingConstraintE() + .Format(NicePrint.stringOfTyparConstraint denv (tpr, tpc)) + ) + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m)) + + | ConstraintSolverTypesNotInEqualityRelation (denv, (TType_measure _ as ty1), (TType_measure _ as ty2), m, m2, _) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + + os.AppendString(ConstraintSolverTypesNotInEqualityRelation1E().Format ty1 ty2) + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m)) + + | ConstraintSolverTypesNotInEqualityRelation (denv, ty1, ty2, m, m2, contextInfo) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + + match contextInfo with + | ContextInfo.IfExpression range when equals range m -> os.AppendString(FSComp.SR.ifExpression (ty1, ty2)) + | ContextInfo.CollectionElement (isArray, range) when equals range m -> + if isArray then + os.AppendString(FSComp.SR.arrayElementHasWrongType (ty1, ty2)) + else + os.AppendString(FSComp.SR.listElementHasWrongType (ty1, ty2)) + | ContextInfo.OmittedElseBranch range when equals range m -> os.AppendString(FSComp.SR.missingElseBranch (ty2)) + | ContextInfo.ElseBranchResult range when equals range m -> os.AppendString(FSComp.SR.elseBranchHasWrongType (ty1, ty2)) + | ContextInfo.FollowingPatternMatchClause range when equals range m -> + os.AppendString(FSComp.SR.followingPatternMatchClauseHasWrongType (ty1, ty2)) + | ContextInfo.PatternMatchGuard range when equals range m -> os.AppendString(FSComp.SR.patternMatchGuardIsNotBool (ty2)) + | _ -> os.AppendString(ConstraintSolverTypesNotInEqualityRelation2E().Format ty1 ty2) + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m)) + + | ConstraintSolverTypesNotInSubsumptionRelation (denv, ty1, ty2, m, m2) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(ConstraintSolverTypesNotInSubsumptionRelationE().Format ty2 ty1 cxs) + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m2)) + + | ConstraintSolverError (msg, m, m2) -> + os.AppendString msg + + if m.StartLine <> m2.StartLine then + os.AppendString(SeeAlsoE().Format(stringOfRange m2)) + + | ErrorFromAddingTypeEquation (g, denv, ty1, ty2, ConstraintSolverTypesNotInEqualityRelation (_, ty1b, ty2b, m, _, contextInfo), _) when + typeEquiv g ty1 ty1b && typeEquiv g ty2 ty2b + -> + let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + + match contextInfo with + | ContextInfo.IfExpression range when equals range m -> os.AppendString(FSComp.SR.ifExpression (ty1, ty2)) + + | ContextInfo.CollectionElement (isArray, range) when equals range m -> + if isArray then + os.AppendString(FSComp.SR.arrayElementHasWrongType (ty1, ty2)) + else + os.AppendString(FSComp.SR.listElementHasWrongType (ty1, ty2)) + + | ContextInfo.OmittedElseBranch range when equals range m -> os.AppendString(FSComp.SR.missingElseBranch (ty2)) + + | ContextInfo.ElseBranchResult range when equals range m -> os.AppendString(FSComp.SR.elseBranchHasWrongType (ty1, ty2)) + + | ContextInfo.FollowingPatternMatchClause range when equals range m -> + os.AppendString(FSComp.SR.followingPatternMatchClauseHasWrongType (ty1, ty2)) + + | ContextInfo.PatternMatchGuard range when equals range m -> os.AppendString(FSComp.SR.patternMatchGuardIsNotBool (ty2)) + + | ContextInfo.TupleInRecordFields -> + os.AppendString(ErrorFromAddingTypeEquation1E().Format ty2 ty1 tpcs) + os.AppendString(Environment.NewLine + FSComp.SR.commaInsteadOfSemicolonInRecord ()) + + | _ when ty2 = "bool" && ty1.EndsWithOrdinal(" ref") -> + os.AppendString(ErrorFromAddingTypeEquation1E().Format ty2 ty1 tpcs) + os.AppendString(Environment.NewLine + FSComp.SR.derefInsteadOfNot ()) + + | _ -> os.AppendString(ErrorFromAddingTypeEquation1E().Format ty2 ty1 tpcs) + + | ErrorFromAddingTypeEquation (_, _, _, _, (ConstraintSolverTypesNotInEqualityRelation (_, _, _, _, _, contextInfo) as e), _) when + (match contextInfo with + | ContextInfo.NoContext -> false + | _ -> true) + -> + OutputExceptionR os e + + | ErrorFromAddingTypeEquation (_, + _, + _, + _, + (ConstraintSolverTypesNotInSubsumptionRelation _ + | ConstraintSolverError _ as e), + _) -> OutputExceptionR os e + + | ErrorFromAddingTypeEquation (g, denv, ty1, ty2, e, _) -> + if not (typeEquiv g ty1 ty2) then + let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + + if ty1 <> ty2 + tpcs then + os.AppendString(ErrorFromAddingTypeEquation2E().Format ty1 ty2 tpcs) + + OutputExceptionR os e + + | ErrorFromApplyingDefault (_, denv, _, defaultType, e, _) -> + let defaultType = NicePrint.minimalStringOfType denv defaultType + os.AppendString(ErrorFromApplyingDefault1E().Format defaultType) + OutputExceptionR os e + os.AppendString(ErrorFromApplyingDefault2E().Format) + + | ErrorsFromAddingSubsumptionConstraint (g, denv, ty1, ty2, e, contextInfo, _) -> + match contextInfo with + | ContextInfo.DowncastUsedInsteadOfUpcast isOperator -> + let ty1, ty2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + + if isOperator then + os.AppendString(FSComp.SR.considerUpcastOperator (ty1, ty2) |> snd) + else + os.AppendString(FSComp.SR.considerUpcast (ty1, ty2) |> snd) + | _ -> + if not (typeEquiv g ty1 ty2) then + let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + + if ty1 <> (ty2 + tpcs) then + os.AppendString(ErrorsFromAddingSubsumptionConstraintE().Format ty2 ty1 tpcs) + else + OutputExceptionR os e + else + OutputExceptionR os e + + | UpperCaseIdentifierInPattern _ -> os.AppendString(UpperCaseIdentifierInPatternE().Format) + + | NotUpperCaseConstructor _ -> os.AppendString(NotUpperCaseConstructorE().Format) + + | ErrorFromAddingConstraint (_, e, _) -> OutputExceptionR os e #if !NO_TYPEPROVIDERS - | TypeProviders.ProvidedTypeResolutionNoRange e + | TypeProviders.ProvidedTypeResolutionNoRange e - | TypeProviders.ProvidedTypeResolution(_, e) -> - OutputExceptionR os e + | TypeProviders.ProvidedTypeResolution (_, e) -> OutputExceptionR os e - | :? TypeProviderError as e -> - os.AppendString(e.ContextualErrorMessage) + | :? TypeProviderError as e -> os.AppendString(e.ContextualErrorMessage) #endif - | UnresolvedOverloading(denv, callerArgs, failure, m) -> - - // extract eventual information (return type and type parameters) - // from ConstraintTraitInfo - let knownReturnType, genericParameterTypes = - match failure with - | NoOverloadsFound (cx=Some cx) - | PossibleCandidates (cx=Some cx) -> cx.ReturnType, cx.ArgumentTypes - | _ -> None, [] - - // prepare message parts (known arguments, known return type, known generic parameters) - let argsMessage, returnType, genericParametersMessage = - - let retTy = - knownReturnType - |> Option.defaultValue (TType_var (Typar.NewUnlinked(), 0uy)) - - let argRepr = - callerArgs.ArgumentNamesAndTypes - |> List.map (fun (name,tTy) -> tTy, {ArgReprInfo.Name = name |> Option.map (fun name -> Ident(name, range.Zero)); ArgReprInfo.Attribs = []}) - - let argsL,retTyL,genParamTysL = NicePrint.prettyLayoutsOfUnresolvedOverloading denv argRepr retTy genericParameterTypes - - match callerArgs.ArgumentNamesAndTypes with - | [] -> None, LayoutRender.showL retTyL, LayoutRender.showL genParamTysL - | items -> - let args = LayoutRender.showL argsL - let prefixMessage = - match items with - | [_] -> FSComp.SR.csNoOverloadsFoundArgumentsPrefixSingular - | _ -> FSComp.SR.csNoOverloadsFoundArgumentsPrefixPlural - Some (prefixMessage args), - LayoutRender.showL retTyL, - LayoutRender.showL genParamTysL - - let knownReturnType = - match knownReturnType with - | None -> None - | Some _ -> Some (FSComp.SR.csNoOverloadsFoundReturnType returnType) - - let genericParametersMessage = - match genericParameterTypes with - | [] -> None - | [_] -> Some (FSComp.SR.csNoOverloadsFoundTypeParametersPrefixSingular genericParametersMessage) - | _ -> Some (FSComp.SR.csNoOverloadsFoundTypeParametersPrefixPlural genericParametersMessage) - - let overloadMethodInfo displayEnv m (x: OverloadInformation) = - let paramInfo = - match x.error with - | :? ArgDoesNotMatchError as x -> - let nameOrOneBasedIndexMessage = - x.calledArg.NameOpt - |> Option.map (fun n -> FSComp.SR.csOverloadCandidateNamedArgumentTypeMismatch n.idText) - |> Option.defaultValue (FSComp.SR.csOverloadCandidateIndexedArgumentTypeMismatch ((vsnd x.calledArg.Position) + 1)) //snd - sprintf " // %s" nameOrOneBasedIndexMessage - | _ -> "" - - (NicePrint.stringOfMethInfo x.infoReader m displayEnv x.methodSlot.Method) + paramInfo - - let nl = Environment.NewLine - let formatOverloads (overloads: OverloadInformation list) = - overloads - |> List.map (overloadMethodInfo denv m) - |> List.sort - |> List.map FSComp.SR.formatDashItem - |> String.concat nl - - // assemble final message composing the parts - let msg = - let optionalParts = - [knownReturnType; genericParametersMessage; argsMessage] - |> List.choose id - |> String.concat (nl + nl) - |> function | "" -> nl - | result -> nl + nl + result + nl + nl - - match failure with - | NoOverloadsFound (methodName, overloads, _) -> - FSComp.SR.csNoOverloadsFound methodName - + optionalParts - + (FSComp.SR.csAvailableOverloads (formatOverloads overloads)) - | PossibleCandidates (methodName, [], _) -> - FSComp.SR.csMethodIsOverloaded methodName - | PossibleCandidates (methodName, overloads, _) -> - FSComp.SR.csMethodIsOverloaded methodName - + optionalParts - + FSComp.SR.csCandidates (formatOverloads overloads) - - os.AppendString msg - - | UnresolvedConversionOperator(denv, fromTy, toTy, _) -> - let ty1, ty2, _tpcs = NicePrint.minimalStringsOfTwoTypes denv fromTy toTy - os.AppendString(FSComp.SR.csTypeDoesNotSupportConversion(ty1, ty2)) - - | FunctionExpected _ -> - os.AppendString(FunctionExpectedE().Format) - - | BakedInMemberConstraintName(nm, _) -> - os.AppendString(BakedInMemberConstraintNameE().Format nm) - - | StandardOperatorRedefinitionWarning(msg, _) -> - os.AppendString msg - - | BadEventTransformation _ -> - os.AppendString(BadEventTransformationE().Format) - - | ParameterlessStructCtor _ -> - os.AppendString(ParameterlessStructCtorE().Format) - - | InterfaceNotRevealed(denv, ity, _) -> - os.AppendString(InterfaceNotRevealedE().Format (NicePrint.minimalStringOfType denv ity)) - - | NotAFunctionButIndexer(_, _, name, _, _, old) -> - if old then - match name with - | Some name -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexerWithName name) - | _ -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexer()) - else - match name with - | Some name -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexerWithName2 name) - | _ -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexer2()) - - | NotAFunction(_, _, _, marg) -> - if marg.StartColumn = 0 then - os.AppendString(FSComp.SR.notAFunctionButMaybeDeclaration()) - else - os.AppendString(FSComp.SR.notAFunction()) - - | TyconBadArgs(_, tcref, d, _) -> - let exp = tcref.TyparsNoRange.Length - if exp = 0 then - os.AppendString(FSComp.SR.buildUnexpectedTypeArgs(fullDisplayTextOfTyconRef tcref, d)) - else - os.AppendString(TyconBadArgsE().Format (fullDisplayTextOfTyconRef tcref) exp d) - - | IndeterminateType _ -> - os.AppendString(IndeterminateTypeE().Format) - - | NameClash(nm, k1, nm1, _, k2, nm2, _) -> - if nm = nm1 && nm1 = nm2 && k1 = k2 then - os.AppendString(NameClash1E().Format k1 nm1) - else - os.AppendString(NameClash2E().Format k1 nm1 nm k2 nm2) - - | Duplicate(k, s, _) -> - if k = "member" then - os.AppendString(Duplicate1E().Format (DecompileOpName s)) - else - os.AppendString(Duplicate2E().Format k (DecompileOpName s)) - - | UndefinedName(_, k, id, suggestionsF) -> - os.AppendString(k (DecompileOpName id.idText)) - suggestNames suggestionsF id.idText - - | InternalUndefinedItemRef(f, smr, ccuName, s) -> - let _, errs = f(smr, ccuName, s) - os.AppendString errs - - | FieldNotMutable _ -> - os.AppendString(FieldNotMutableE().Format) - - | FieldsFromDifferentTypes (_, fref1, fref2, _) -> - os.AppendString(FieldsFromDifferentTypesE().Format fref1.FieldName fref2.FieldName) - - | VarBoundTwice id -> - os.AppendString(VarBoundTwiceE().Format (DecompileOpName id.idText)) - - | Recursion (denv, id, ty1, ty2, _) -> - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(RecursionE().Format (DecompileOpName id.idText) ty1 ty2 tpcs) - - | InvalidRuntimeCoercion(denv, ty1, ty2, _) -> - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(InvalidRuntimeCoercionE().Format ty1 ty2 tpcs) - - | IndeterminateRuntimeCoercion(denv, ty1, ty2, _) -> - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(IndeterminateRuntimeCoercionE().Format ty1 ty2) - - | IndeterminateStaticCoercion(denv, ty1, ty2, _) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(IndeterminateStaticCoercionE().Format ty1 ty2) - - | StaticCoercionShouldUseBox(denv, ty1, ty2, _) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(StaticCoercionShouldUseBoxE().Format ty1 ty2) - - | TypeIsImplicitlyAbstract _ -> - os.AppendString(TypeIsImplicitlyAbstractE().Format) - - | NonRigidTypar(denv, tpnmOpt, typarRange, ty1, ty2, _) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let (ty1, ty2), _cxs = PrettyTypes.PrettifyTypePair denv.g (ty1, ty2) - match tpnmOpt with - | None -> - os.AppendString(NonRigidTypar1E().Format (stringOfRange typarRange) (NicePrint.stringOfTy denv ty2)) - | Some tpnm -> - match ty1 with - | TType_measure _ -> - os.AppendString(NonRigidTypar2E().Format tpnm (NicePrint.stringOfTy denv ty2)) - | _ -> - os.AppendString(NonRigidTypar3E().Format tpnm (NicePrint.stringOfTy denv ty2)) - - | SyntaxError (ctxt, _) -> - let ctxt = unbox>(ctxt) - - let (|EndOfStructuredConstructToken|_|) token = - match token with - | Parser.TOKEN_ODECLEND - | Parser.TOKEN_OBLOCKSEP - | Parser.TOKEN_OEND - | Parser.TOKEN_ORIGHT_BLOCK_END - | Parser.TOKEN_OBLOCKEND | Parser.TOKEN_OBLOCKEND_COMING_SOON | Parser.TOKEN_OBLOCKEND_IS_HERE -> Some() - | _ -> None - - let tokenIdToText tid = - match tid with - | Parser.TOKEN_IDENT -> getErrorString("Parser.TOKEN.IDENT") - | Parser.TOKEN_BIGNUM - | Parser.TOKEN_INT8 - | Parser.TOKEN_UINT8 - | Parser.TOKEN_INT16 - | Parser.TOKEN_UINT16 - | Parser.TOKEN_INT32 - | Parser.TOKEN_UINT32 - | Parser.TOKEN_INT64 - | Parser.TOKEN_UINT64 - | Parser.TOKEN_UNATIVEINT - | Parser.TOKEN_NATIVEINT -> getErrorString("Parser.TOKEN.INT") - | Parser.TOKEN_IEEE32 - | Parser.TOKEN_IEEE64 -> getErrorString("Parser.TOKEN.FLOAT") - | Parser.TOKEN_DECIMAL -> getErrorString("Parser.TOKEN.DECIMAL") - | Parser.TOKEN_CHAR -> getErrorString("Parser.TOKEN.CHAR") - - | Parser.TOKEN_BASE -> getErrorString("Parser.TOKEN.BASE") - | Parser.TOKEN_LPAREN_STAR_RPAREN -> getErrorString("Parser.TOKEN.LPAREN.STAR.RPAREN") - | Parser.TOKEN_DOLLAR -> getErrorString("Parser.TOKEN.DOLLAR") - | Parser.TOKEN_INFIX_STAR_STAR_OP -> getErrorString("Parser.TOKEN.INFIX.STAR.STAR.OP") - | Parser.TOKEN_INFIX_COMPARE_OP -> getErrorString("Parser.TOKEN.INFIX.COMPARE.OP") - | Parser.TOKEN_COLON_GREATER -> getErrorString("Parser.TOKEN.COLON.GREATER") - | Parser.TOKEN_COLON_COLON ->getErrorString("Parser.TOKEN.COLON.COLON") - | Parser.TOKEN_PERCENT_OP -> getErrorString("Parser.TOKEN.PERCENT.OP") - | Parser.TOKEN_INFIX_AT_HAT_OP -> getErrorString("Parser.TOKEN.INFIX.AT.HAT.OP") - | Parser.TOKEN_INFIX_BAR_OP -> getErrorString("Parser.TOKEN.INFIX.BAR.OP") - | Parser.TOKEN_PLUS_MINUS_OP -> getErrorString("Parser.TOKEN.PLUS.MINUS.OP") - | Parser.TOKEN_PREFIX_OP -> getErrorString("Parser.TOKEN.PREFIX.OP") - | Parser.TOKEN_COLON_QMARK_GREATER -> getErrorString("Parser.TOKEN.COLON.QMARK.GREATER") - | Parser.TOKEN_INFIX_STAR_DIV_MOD_OP -> getErrorString("Parser.TOKEN.INFIX.STAR.DIV.MOD.OP") - | Parser.TOKEN_INFIX_AMP_OP -> getErrorString("Parser.TOKEN.INFIX.AMP.OP") - | Parser.TOKEN_AMP -> getErrorString("Parser.TOKEN.AMP") - | Parser.TOKEN_AMP_AMP -> getErrorString("Parser.TOKEN.AMP.AMP") - | Parser.TOKEN_BAR_BAR -> getErrorString("Parser.TOKEN.BAR.BAR") - | Parser.TOKEN_LESS -> getErrorString("Parser.TOKEN.LESS") - | Parser.TOKEN_GREATER -> getErrorString("Parser.TOKEN.GREATER") - | Parser.TOKEN_QMARK -> getErrorString("Parser.TOKEN.QMARK") - | Parser.TOKEN_QMARK_QMARK -> getErrorString("Parser.TOKEN.QMARK.QMARK") - | Parser.TOKEN_COLON_QMARK-> getErrorString("Parser.TOKEN.COLON.QMARK") - | Parser.TOKEN_INT32_DOT_DOT -> getErrorString("Parser.TOKEN.INT32.DOT.DOT") - | Parser.TOKEN_DOT_DOT -> getErrorString("Parser.TOKEN.DOT.DOT") - | Parser.TOKEN_DOT_DOT_HAT -> getErrorString("Parser.TOKEN.DOT.DOT") - | Parser.TOKEN_QUOTE -> getErrorString("Parser.TOKEN.QUOTE") - | Parser.TOKEN_STAR -> getErrorString("Parser.TOKEN.STAR") - | Parser.TOKEN_HIGH_PRECEDENCE_TYAPP -> getErrorString("Parser.TOKEN.HIGH.PRECEDENCE.TYAPP") - | Parser.TOKEN_COLON -> getErrorString("Parser.TOKEN.COLON") - | Parser.TOKEN_COLON_EQUALS -> getErrorString("Parser.TOKEN.COLON.EQUALS") - | Parser.TOKEN_LARROW -> getErrorString("Parser.TOKEN.LARROW") - | Parser.TOKEN_EQUALS -> getErrorString("Parser.TOKEN.EQUALS") - | Parser.TOKEN_GREATER_BAR_RBRACK -> getErrorString("Parser.TOKEN.GREATER.BAR.RBRACK") - | Parser.TOKEN_MINUS -> getErrorString("Parser.TOKEN.MINUS") - | Parser.TOKEN_ADJACENT_PREFIX_OP -> getErrorString("Parser.TOKEN.ADJACENT.PREFIX.OP") - | Parser.TOKEN_FUNKY_OPERATOR_NAME -> getErrorString("Parser.TOKEN.FUNKY.OPERATOR.NAME") - | Parser.TOKEN_COMMA-> getErrorString("Parser.TOKEN.COMMA") - | Parser.TOKEN_DOT -> getErrorString("Parser.TOKEN.DOT") - | Parser.TOKEN_BAR-> getErrorString("Parser.TOKEN.BAR") - | Parser.TOKEN_HASH -> getErrorString("Parser.TOKEN.HASH") - | Parser.TOKEN_UNDERSCORE -> getErrorString("Parser.TOKEN.UNDERSCORE") - | Parser.TOKEN_SEMICOLON -> getErrorString("Parser.TOKEN.SEMICOLON") - | Parser.TOKEN_SEMICOLON_SEMICOLON-> getErrorString("Parser.TOKEN.SEMICOLON.SEMICOLON") - | Parser.TOKEN_LPAREN-> getErrorString("Parser.TOKEN.LPAREN") - | Parser.TOKEN_RPAREN | Parser.TOKEN_RPAREN_COMING_SOON | Parser.TOKEN_RPAREN_IS_HERE -> getErrorString("Parser.TOKEN.RPAREN") - | Parser.TOKEN_LQUOTE -> getErrorString("Parser.TOKEN.LQUOTE") - | Parser.TOKEN_LBRACK -> getErrorString("Parser.TOKEN.LBRACK") - | Parser.TOKEN_LBRACE_BAR -> getErrorString("Parser.TOKEN.LBRACE.BAR") - | Parser.TOKEN_LBRACK_BAR -> getErrorString("Parser.TOKEN.LBRACK.BAR") - | Parser.TOKEN_LBRACK_LESS -> getErrorString("Parser.TOKEN.LBRACK.LESS") - | Parser.TOKEN_LBRACE -> getErrorString("Parser.TOKEN.LBRACE") - | Parser.TOKEN_BAR_RBRACK -> getErrorString("Parser.TOKEN.BAR.RBRACK") - | Parser.TOKEN_BAR_RBRACE -> getErrorString("Parser.TOKEN.BAR.RBRACE") - | Parser.TOKEN_GREATER_RBRACK -> getErrorString("Parser.TOKEN.GREATER.RBRACK") - | Parser.TOKEN_RQUOTE_DOT _ - | Parser.TOKEN_RQUOTE -> getErrorString("Parser.TOKEN.RQUOTE") - | Parser.TOKEN_RBRACK -> getErrorString("Parser.TOKEN.RBRACK") - | Parser.TOKEN_RBRACE | Parser.TOKEN_RBRACE_COMING_SOON | Parser.TOKEN_RBRACE_IS_HERE -> getErrorString("Parser.TOKEN.RBRACE") - | Parser.TOKEN_PUBLIC -> getErrorString("Parser.TOKEN.PUBLIC") - | Parser.TOKEN_PRIVATE -> getErrorString("Parser.TOKEN.PRIVATE") - | Parser.TOKEN_INTERNAL -> getErrorString("Parser.TOKEN.INTERNAL") - | Parser.TOKEN_CONSTRAINT -> getErrorString("Parser.TOKEN.CONSTRAINT") - | Parser.TOKEN_INSTANCE -> getErrorString("Parser.TOKEN.INSTANCE") - | Parser.TOKEN_DELEGATE -> getErrorString("Parser.TOKEN.DELEGATE") - | Parser.TOKEN_INHERIT -> getErrorString("Parser.TOKEN.INHERIT") - | Parser.TOKEN_CONSTRUCTOR-> getErrorString("Parser.TOKEN.CONSTRUCTOR") - | Parser.TOKEN_DEFAULT -> getErrorString("Parser.TOKEN.DEFAULT") - | Parser.TOKEN_OVERRIDE-> getErrorString("Parser.TOKEN.OVERRIDE") - | Parser.TOKEN_ABSTRACT-> getErrorString("Parser.TOKEN.ABSTRACT") - | Parser.TOKEN_CLASS-> getErrorString("Parser.TOKEN.CLASS") - | Parser.TOKEN_MEMBER -> getErrorString("Parser.TOKEN.MEMBER") - | Parser.TOKEN_STATIC -> getErrorString("Parser.TOKEN.STATIC") - | Parser.TOKEN_NAMESPACE-> getErrorString("Parser.TOKEN.NAMESPACE") - | Parser.TOKEN_OBLOCKBEGIN -> getErrorString("Parser.TOKEN.OBLOCKBEGIN") - | EndOfStructuredConstructToken -> getErrorString("Parser.TOKEN.OBLOCKEND") - | Parser.TOKEN_THEN - | Parser.TOKEN_OTHEN -> getErrorString("Parser.TOKEN.OTHEN") - | Parser.TOKEN_ELSE - | Parser.TOKEN_OELSE -> getErrorString("Parser.TOKEN.OELSE") - | Parser.TOKEN_LET _ - | Parser.TOKEN_OLET _ -> getErrorString("Parser.TOKEN.OLET") - | Parser.TOKEN_OBINDER - | Parser.TOKEN_BINDER -> getErrorString("Parser.TOKEN.BINDER") - | Parser.TOKEN_OAND_BANG - | Parser.TOKEN_AND_BANG -> getErrorString("Parser.TOKEN.AND.BANG") - | Parser.TOKEN_ODO -> getErrorString("Parser.TOKEN.ODO") - | Parser.TOKEN_OWITH -> getErrorString("Parser.TOKEN.OWITH") - | Parser.TOKEN_OFUNCTION -> getErrorString("Parser.TOKEN.OFUNCTION") - | Parser.TOKEN_OFUN -> getErrorString("Parser.TOKEN.OFUN") - | Parser.TOKEN_ORESET -> getErrorString("Parser.TOKEN.ORESET") - | Parser.TOKEN_ODUMMY -> getErrorString("Parser.TOKEN.ODUMMY") - | Parser.TOKEN_DO_BANG - | Parser.TOKEN_ODO_BANG -> getErrorString("Parser.TOKEN.ODO.BANG") - | Parser.TOKEN_YIELD -> getErrorString("Parser.TOKEN.YIELD") - | Parser.TOKEN_YIELD_BANG -> getErrorString("Parser.TOKEN.YIELD.BANG") - | Parser.TOKEN_OINTERFACE_MEMBER-> getErrorString("Parser.TOKEN.OINTERFACE.MEMBER") - | Parser.TOKEN_ELIF -> getErrorString("Parser.TOKEN.ELIF") - | Parser.TOKEN_RARROW -> getErrorString("Parser.TOKEN.RARROW") - | Parser.TOKEN_SIG -> getErrorString("Parser.TOKEN.SIG") - | Parser.TOKEN_STRUCT -> getErrorString("Parser.TOKEN.STRUCT") - | Parser.TOKEN_UPCAST -> getErrorString("Parser.TOKEN.UPCAST") - | Parser.TOKEN_DOWNCAST -> getErrorString("Parser.TOKEN.DOWNCAST") - | Parser.TOKEN_NULL -> getErrorString("Parser.TOKEN.NULL") - | Parser.TOKEN_RESERVED -> getErrorString("Parser.TOKEN.RESERVED") - | Parser.TOKEN_MODULE | Parser.TOKEN_MODULE_COMING_SOON | Parser.TOKEN_MODULE_IS_HERE -> getErrorString("Parser.TOKEN.MODULE") - | Parser.TOKEN_AND -> getErrorString("Parser.TOKEN.AND") - | Parser.TOKEN_AS -> getErrorString("Parser.TOKEN.AS") - | Parser.TOKEN_ASSERT -> getErrorString("Parser.TOKEN.ASSERT") - | Parser.TOKEN_OASSERT -> getErrorString("Parser.TOKEN.ASSERT") - | Parser.TOKEN_ASR-> getErrorString("Parser.TOKEN.ASR") - | Parser.TOKEN_DOWNTO -> getErrorString("Parser.TOKEN.DOWNTO") - | Parser.TOKEN_EXCEPTION -> getErrorString("Parser.TOKEN.EXCEPTION") - | Parser.TOKEN_FALSE -> getErrorString("Parser.TOKEN.FALSE") - | Parser.TOKEN_FOR -> getErrorString("Parser.TOKEN.FOR") - | Parser.TOKEN_FUN -> getErrorString("Parser.TOKEN.FUN") - | Parser.TOKEN_FUNCTION-> getErrorString("Parser.TOKEN.FUNCTION") - | Parser.TOKEN_FINALLY -> getErrorString("Parser.TOKEN.FINALLY") - | Parser.TOKEN_LAZY -> getErrorString("Parser.TOKEN.LAZY") - | Parser.TOKEN_OLAZY -> getErrorString("Parser.TOKEN.LAZY") - | Parser.TOKEN_MATCH -> getErrorString("Parser.TOKEN.MATCH") - | Parser.TOKEN_MATCH_BANG -> getErrorString("Parser.TOKEN.MATCH.BANG") - | Parser.TOKEN_MUTABLE -> getErrorString("Parser.TOKEN.MUTABLE") - | Parser.TOKEN_NEW -> getErrorString("Parser.TOKEN.NEW") - | Parser.TOKEN_OF -> getErrorString("Parser.TOKEN.OF") - | Parser.TOKEN_OPEN -> getErrorString("Parser.TOKEN.OPEN") - | Parser.TOKEN_OR -> getErrorString("Parser.TOKEN.OR") - | Parser.TOKEN_VOID -> getErrorString("Parser.TOKEN.VOID") - | Parser.TOKEN_EXTERN-> getErrorString("Parser.TOKEN.EXTERN") - | Parser.TOKEN_INTERFACE -> getErrorString("Parser.TOKEN.INTERFACE") - | Parser.TOKEN_REC -> getErrorString("Parser.TOKEN.REC") - | Parser.TOKEN_TO -> getErrorString("Parser.TOKEN.TO") - | Parser.TOKEN_TRUE -> getErrorString("Parser.TOKEN.TRUE") - | Parser.TOKEN_TRY -> getErrorString("Parser.TOKEN.TRY") - | Parser.TOKEN_TYPE | Parser.TOKEN_TYPE_COMING_SOON | Parser.TOKEN_TYPE_IS_HERE -> getErrorString("Parser.TOKEN.TYPE") - | Parser.TOKEN_VAL -> getErrorString("Parser.TOKEN.VAL") - | Parser.TOKEN_INLINE -> getErrorString("Parser.TOKEN.INLINE") - | Parser.TOKEN_WHEN -> getErrorString("Parser.TOKEN.WHEN") - | Parser.TOKEN_WHILE -> getErrorString("Parser.TOKEN.WHILE") - | Parser.TOKEN_WITH-> getErrorString("Parser.TOKEN.WITH") - | Parser.TOKEN_IF -> getErrorString("Parser.TOKEN.IF") - | Parser.TOKEN_DO -> getErrorString("Parser.TOKEN.DO") - | Parser.TOKEN_GLOBAL -> getErrorString("Parser.TOKEN.GLOBAL") - | Parser.TOKEN_DONE -> getErrorString("Parser.TOKEN.DONE") - | Parser.TOKEN_IN | Parser.TOKEN_JOIN_IN -> getErrorString("Parser.TOKEN.IN") - | Parser.TOKEN_HIGH_PRECEDENCE_PAREN_APP-> getErrorString("Parser.TOKEN.HIGH.PRECEDENCE.PAREN.APP") - | Parser.TOKEN_HIGH_PRECEDENCE_BRACK_APP-> getErrorString("Parser.TOKEN.HIGH.PRECEDENCE.BRACK.APP") - | Parser.TOKEN_BEGIN -> getErrorString("Parser.TOKEN.BEGIN") - | Parser.TOKEN_END -> getErrorString("Parser.TOKEN.END") - | Parser.TOKEN_HASH_LIGHT - | Parser.TOKEN_HASH_LINE - | Parser.TOKEN_HASH_IF - | Parser.TOKEN_HASH_ELSE - | Parser.TOKEN_HASH_ENDIF -> getErrorString("Parser.TOKEN.HASH.ENDIF") - | Parser.TOKEN_INACTIVECODE -> getErrorString("Parser.TOKEN.INACTIVECODE") - | Parser.TOKEN_LEX_FAILURE-> getErrorString("Parser.TOKEN.LEX.FAILURE") - | Parser.TOKEN_WHITESPACE -> getErrorString("Parser.TOKEN.WHITESPACE") - | Parser.TOKEN_COMMENT -> getErrorString("Parser.TOKEN.COMMENT") - | Parser.TOKEN_LINE_COMMENT -> getErrorString("Parser.TOKEN.LINE.COMMENT") - | Parser.TOKEN_STRING_TEXT -> getErrorString("Parser.TOKEN.STRING.TEXT") - | Parser.TOKEN_BYTEARRAY -> getErrorString("Parser.TOKEN.BYTEARRAY") - | Parser.TOKEN_STRING -> getErrorString("Parser.TOKEN.STRING") - | Parser.TOKEN_KEYWORD_STRING -> getErrorString("Parser.TOKEN.KEYWORD_STRING") - | Parser.TOKEN_EOF -> getErrorString("Parser.TOKEN.EOF") - | Parser.TOKEN_CONST -> getErrorString("Parser.TOKEN.CONST") - | Parser.TOKEN_FIXED -> getErrorString("Parser.TOKEN.FIXED") - | Parser.TOKEN_INTERP_STRING_BEGIN_END -> getErrorString("Parser.TOKEN.INTERP.STRING.BEGIN.END") - | Parser.TOKEN_INTERP_STRING_BEGIN_PART -> getErrorString("Parser.TOKEN.INTERP.STRING.BEGIN.PART") - | Parser.TOKEN_INTERP_STRING_PART -> getErrorString("Parser.TOKEN.INTERP.STRING.PART") - | Parser.TOKEN_INTERP_STRING_END -> getErrorString("Parser.TOKEN.INTERP.STRING.END") - | unknown -> - Debug.Assert(false, "unknown token tag") - let result = sprintf "%+A" unknown - Debug.Assert(false, result) - result + | UnresolvedOverloading (denv, callerArgs, failure, m) -> + + // extract eventual information (return type and type parameters) + // from ConstraintTraitInfo + let knownReturnType, genericParameterTypes = + match failure with + | NoOverloadsFound(cx = Some cx) + | PossibleCandidates(cx = Some cx) -> cx.ReturnType, cx.ArgumentTypes + | _ -> None, [] + + // prepare message parts (known arguments, known return type, known generic parameters) + let argsMessage, returnType, genericParametersMessage = + + let retTy = + knownReturnType |> Option.defaultValue (TType_var(Typar.NewUnlinked(), 0uy)) + + let argRepr = + callerArgs.ArgumentNamesAndTypes + |> List.map (fun (name, tTy) -> + tTy, + { + ArgReprInfo.Name = name |> Option.map (fun name -> Ident(name, range.Zero)) + ArgReprInfo.Attribs = [] + }) + + let argsL, retTyL, genParamTysL = + NicePrint.prettyLayoutsOfUnresolvedOverloading denv argRepr retTy genericParameterTypes + + match callerArgs.ArgumentNamesAndTypes with + | [] -> None, LayoutRender.showL retTyL, LayoutRender.showL genParamTysL + | items -> + let args = LayoutRender.showL argsL + + let prefixMessage = + match items with + | [ _ ] -> FSComp.SR.csNoOverloadsFoundArgumentsPrefixSingular + | _ -> FSComp.SR.csNoOverloadsFoundArgumentsPrefixPlural + + Some(prefixMessage args), LayoutRender.showL retTyL, LayoutRender.showL genParamTysL + + let knownReturnType = + match knownReturnType with + | None -> None + | Some _ -> Some(FSComp.SR.csNoOverloadsFoundReturnType returnType) + + let genericParametersMessage = + match genericParameterTypes with + | [] -> None + | [ _ ] -> Some(FSComp.SR.csNoOverloadsFoundTypeParametersPrefixSingular genericParametersMessage) + | _ -> Some(FSComp.SR.csNoOverloadsFoundTypeParametersPrefixPlural genericParametersMessage) + + let overloadMethodInfo displayEnv m (x: OverloadInformation) = + let paramInfo = + match x.error with + | :? ArgDoesNotMatchError as x -> + let nameOrOneBasedIndexMessage = + x.calledArg.NameOpt + |> Option.map (fun n -> FSComp.SR.csOverloadCandidateNamedArgumentTypeMismatch n.idText) + |> Option.defaultValue ( + FSComp.SR.csOverloadCandidateIndexedArgumentTypeMismatch ((vsnd x.calledArg.Position) + 1) + ) //snd + + sprintf " // %s" nameOrOneBasedIndexMessage + | _ -> "" + + (NicePrint.stringOfMethInfo x.infoReader m displayEnv x.methodSlot.Method) + + paramInfo + + let nl = Environment.NewLine + + let formatOverloads (overloads: OverloadInformation list) = + overloads + |> List.map (overloadMethodInfo denv m) + |> List.sort + |> List.map FSComp.SR.formatDashItem + |> String.concat nl + + // assemble final message composing the parts + let msg = + let optionalParts = + [ knownReturnType; genericParametersMessage; argsMessage ] + |> List.choose id + |> String.concat (nl + nl) + |> function + | "" -> nl + | result -> nl + nl + result + nl + nl + + match failure with + | NoOverloadsFound (methodName, overloads, _) -> + FSComp.SR.csNoOverloadsFound methodName + + optionalParts + + (FSComp.SR.csAvailableOverloads (formatOverloads overloads)) + | PossibleCandidates (methodName, [], _) -> FSComp.SR.csMethodIsOverloaded methodName + | PossibleCandidates (methodName, overloads, _) -> + FSComp.SR.csMethodIsOverloaded methodName + + optionalParts + + FSComp.SR.csCandidates (formatOverloads overloads) + + os.AppendString msg + + | UnresolvedConversionOperator (denv, fromTy, toTy, _) -> + let ty1, ty2, _tpcs = NicePrint.minimalStringsOfTwoTypes denv fromTy toTy + os.AppendString(FSComp.SR.csTypeDoesNotSupportConversion (ty1, ty2)) + + | FunctionExpected _ -> os.AppendString(FunctionExpectedE().Format) + + | BakedInMemberConstraintName (nm, _) -> os.AppendString(BakedInMemberConstraintNameE().Format nm) + + | StandardOperatorRedefinitionWarning (msg, _) -> os.AppendString msg + + | BadEventTransformation _ -> os.AppendString(BadEventTransformationE().Format) + + | ParameterlessStructCtor _ -> os.AppendString(ParameterlessStructCtorE().Format) + + | InterfaceNotRevealed (denv, ity, _) -> os.AppendString(InterfaceNotRevealedE().Format(NicePrint.minimalStringOfType denv ity)) + + | NotAFunctionButIndexer (_, _, name, _, _, old) -> + if old then + match name with + | Some name -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexerWithName name) + | _ -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexer ()) + else + match name with + | Some name -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexerWithName2 name) + | _ -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexer2 ()) + + | NotAFunction (_, _, _, marg) -> + if marg.StartColumn = 0 then + os.AppendString(FSComp.SR.notAFunctionButMaybeDeclaration ()) + else + os.AppendString(FSComp.SR.notAFunction ()) + + | TyconBadArgs (_, tcref, d, _) -> + let exp = tcref.TyparsNoRange.Length + + if exp = 0 then + os.AppendString(FSComp.SR.buildUnexpectedTypeArgs (fullDisplayTextOfTyconRef tcref, d)) + else + os.AppendString(TyconBadArgsE().Format (fullDisplayTextOfTyconRef tcref) exp d) + + | IndeterminateType _ -> os.AppendString(IndeterminateTypeE().Format) + + | NameClash (nm, k1, nm1, _, k2, nm2, _) -> + if nm = nm1 && nm1 = nm2 && k1 = k2 then + os.AppendString(NameClash1E().Format k1 nm1) + else + os.AppendString(NameClash2E().Format k1 nm1 nm k2 nm2) + + | Duplicate (k, s, _) -> + if k = "member" then + os.AppendString(Duplicate1E().Format(DecompileOpName s)) + else + os.AppendString(Duplicate2E().Format k (DecompileOpName s)) + + | UndefinedName (_, k, id, suggestionsF) -> + os.AppendString(k (DecompileOpName id.idText)) + suggestNames suggestionsF id.idText + + | InternalUndefinedItemRef (f, smr, ccuName, s) -> + let _, errs = f (smr, ccuName, s) + os.AppendString errs + + | FieldNotMutable _ -> os.AppendString(FieldNotMutableE().Format) + + | FieldsFromDifferentTypes (_, fref1, fref2, _) -> + os.AppendString(FieldsFromDifferentTypesE().Format fref1.FieldName fref2.FieldName) + + | VarBoundTwice id -> os.AppendString(VarBoundTwiceE().Format(DecompileOpName id.idText)) + + | Recursion (denv, id, ty1, ty2, _) -> + let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(RecursionE().Format (DecompileOpName id.idText) ty1 ty2 tpcs) + + | InvalidRuntimeCoercion (denv, ty1, ty2, _) -> + let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(InvalidRuntimeCoercionE().Format ty1 ty2 tpcs) + + | IndeterminateRuntimeCoercion (denv, ty1, ty2, _) -> + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(IndeterminateRuntimeCoercionE().Format ty1 ty2) + + | IndeterminateStaticCoercion (denv, ty1, ty2, _) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(IndeterminateStaticCoercionE().Format ty1 ty2) + + | StaticCoercionShouldUseBox (denv, ty1, ty2, _) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(StaticCoercionShouldUseBoxE().Format ty1 ty2) + + | TypeIsImplicitlyAbstract _ -> os.AppendString(TypeIsImplicitlyAbstractE().Format) + + | NonRigidTypar (denv, tpnmOpt, typarRange, ty1, ty2, _) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let (ty1, ty2), _cxs = PrettyTypes.PrettifyTypePair denv.g (ty1, ty2) + + match tpnmOpt with + | None -> os.AppendString(NonRigidTypar1E().Format (stringOfRange typarRange) (NicePrint.stringOfTy denv ty2)) + | Some tpnm -> + match ty1 with + | TType_measure _ -> os.AppendString(NonRigidTypar2E().Format tpnm (NicePrint.stringOfTy denv ty2)) + | _ -> os.AppendString(NonRigidTypar3E().Format tpnm (NicePrint.stringOfTy denv ty2)) + + | SyntaxError (ctxt, _) -> + let ctxt = unbox> (ctxt) + + let (|EndOfStructuredConstructToken|_|) token = + match token with + | Parser.TOKEN_ODECLEND + | Parser.TOKEN_OBLOCKSEP + | Parser.TOKEN_OEND + | Parser.TOKEN_ORIGHT_BLOCK_END + | Parser.TOKEN_OBLOCKEND + | Parser.TOKEN_OBLOCKEND_COMING_SOON + | Parser.TOKEN_OBLOCKEND_IS_HERE -> Some() + | _ -> None + + let tokenIdToText tid = + match tid with + | Parser.TOKEN_IDENT -> getErrorString ("Parser.TOKEN.IDENT") + | Parser.TOKEN_BIGNUM + | Parser.TOKEN_INT8 + | Parser.TOKEN_UINT8 + | Parser.TOKEN_INT16 + | Parser.TOKEN_UINT16 + | Parser.TOKEN_INT32 + | Parser.TOKEN_UINT32 + | Parser.TOKEN_INT64 + | Parser.TOKEN_UINT64 + | Parser.TOKEN_UNATIVEINT + | Parser.TOKEN_NATIVEINT -> getErrorString ("Parser.TOKEN.INT") + | Parser.TOKEN_IEEE32 + | Parser.TOKEN_IEEE64 -> getErrorString ("Parser.TOKEN.FLOAT") + | Parser.TOKEN_DECIMAL -> getErrorString ("Parser.TOKEN.DECIMAL") + | Parser.TOKEN_CHAR -> getErrorString ("Parser.TOKEN.CHAR") + + | Parser.TOKEN_BASE -> getErrorString ("Parser.TOKEN.BASE") + | Parser.TOKEN_LPAREN_STAR_RPAREN -> getErrorString ("Parser.TOKEN.LPAREN.STAR.RPAREN") + | Parser.TOKEN_DOLLAR -> getErrorString ("Parser.TOKEN.DOLLAR") + | Parser.TOKEN_INFIX_STAR_STAR_OP -> getErrorString ("Parser.TOKEN.INFIX.STAR.STAR.OP") + | Parser.TOKEN_INFIX_COMPARE_OP -> getErrorString ("Parser.TOKEN.INFIX.COMPARE.OP") + | Parser.TOKEN_COLON_GREATER -> getErrorString ("Parser.TOKEN.COLON.GREATER") + | Parser.TOKEN_COLON_COLON -> getErrorString ("Parser.TOKEN.COLON.COLON") + | Parser.TOKEN_PERCENT_OP -> getErrorString ("Parser.TOKEN.PERCENT.OP") + | Parser.TOKEN_INFIX_AT_HAT_OP -> getErrorString ("Parser.TOKEN.INFIX.AT.HAT.OP") + | Parser.TOKEN_INFIX_BAR_OP -> getErrorString ("Parser.TOKEN.INFIX.BAR.OP") + | Parser.TOKEN_PLUS_MINUS_OP -> getErrorString ("Parser.TOKEN.PLUS.MINUS.OP") + | Parser.TOKEN_PREFIX_OP -> getErrorString ("Parser.TOKEN.PREFIX.OP") + | Parser.TOKEN_COLON_QMARK_GREATER -> getErrorString ("Parser.TOKEN.COLON.QMARK.GREATER") + | Parser.TOKEN_INFIX_STAR_DIV_MOD_OP -> getErrorString ("Parser.TOKEN.INFIX.STAR.DIV.MOD.OP") + | Parser.TOKEN_INFIX_AMP_OP -> getErrorString ("Parser.TOKEN.INFIX.AMP.OP") + | Parser.TOKEN_AMP -> getErrorString ("Parser.TOKEN.AMP") + | Parser.TOKEN_AMP_AMP -> getErrorString ("Parser.TOKEN.AMP.AMP") + | Parser.TOKEN_BAR_BAR -> getErrorString ("Parser.TOKEN.BAR.BAR") + | Parser.TOKEN_LESS -> getErrorString ("Parser.TOKEN.LESS") + | Parser.TOKEN_GREATER -> getErrorString ("Parser.TOKEN.GREATER") + | Parser.TOKEN_QMARK -> getErrorString ("Parser.TOKEN.QMARK") + | Parser.TOKEN_QMARK_QMARK -> getErrorString ("Parser.TOKEN.QMARK.QMARK") + | Parser.TOKEN_COLON_QMARK -> getErrorString ("Parser.TOKEN.COLON.QMARK") + | Parser.TOKEN_INT32_DOT_DOT -> getErrorString ("Parser.TOKEN.INT32.DOT.DOT") + | Parser.TOKEN_DOT_DOT -> getErrorString ("Parser.TOKEN.DOT.DOT") + | Parser.TOKEN_DOT_DOT_HAT -> getErrorString ("Parser.TOKEN.DOT.DOT") + | Parser.TOKEN_QUOTE -> getErrorString ("Parser.TOKEN.QUOTE") + | Parser.TOKEN_STAR -> getErrorString ("Parser.TOKEN.STAR") + | Parser.TOKEN_HIGH_PRECEDENCE_TYAPP -> getErrorString ("Parser.TOKEN.HIGH.PRECEDENCE.TYAPP") + | Parser.TOKEN_COLON -> getErrorString ("Parser.TOKEN.COLON") + | Parser.TOKEN_COLON_EQUALS -> getErrorString ("Parser.TOKEN.COLON.EQUALS") + | Parser.TOKEN_LARROW -> getErrorString ("Parser.TOKEN.LARROW") + | Parser.TOKEN_EQUALS -> getErrorString ("Parser.TOKEN.EQUALS") + | Parser.TOKEN_GREATER_BAR_RBRACK -> getErrorString ("Parser.TOKEN.GREATER.BAR.RBRACK") + | Parser.TOKEN_MINUS -> getErrorString ("Parser.TOKEN.MINUS") + | Parser.TOKEN_ADJACENT_PREFIX_OP -> getErrorString ("Parser.TOKEN.ADJACENT.PREFIX.OP") + | Parser.TOKEN_FUNKY_OPERATOR_NAME -> getErrorString ("Parser.TOKEN.FUNKY.OPERATOR.NAME") + | Parser.TOKEN_COMMA -> getErrorString ("Parser.TOKEN.COMMA") + | Parser.TOKEN_DOT -> getErrorString ("Parser.TOKEN.DOT") + | Parser.TOKEN_BAR -> getErrorString ("Parser.TOKEN.BAR") + | Parser.TOKEN_HASH -> getErrorString ("Parser.TOKEN.HASH") + | Parser.TOKEN_UNDERSCORE -> getErrorString ("Parser.TOKEN.UNDERSCORE") + | Parser.TOKEN_SEMICOLON -> getErrorString ("Parser.TOKEN.SEMICOLON") + | Parser.TOKEN_SEMICOLON_SEMICOLON -> getErrorString ("Parser.TOKEN.SEMICOLON.SEMICOLON") + | Parser.TOKEN_LPAREN -> getErrorString ("Parser.TOKEN.LPAREN") + | Parser.TOKEN_RPAREN + | Parser.TOKEN_RPAREN_COMING_SOON + | Parser.TOKEN_RPAREN_IS_HERE -> getErrorString ("Parser.TOKEN.RPAREN") + | Parser.TOKEN_LQUOTE -> getErrorString ("Parser.TOKEN.LQUOTE") + | Parser.TOKEN_LBRACK -> getErrorString ("Parser.TOKEN.LBRACK") + | Parser.TOKEN_LBRACE_BAR -> getErrorString ("Parser.TOKEN.LBRACE.BAR") + | Parser.TOKEN_LBRACK_BAR -> getErrorString ("Parser.TOKEN.LBRACK.BAR") + | Parser.TOKEN_LBRACK_LESS -> getErrorString ("Parser.TOKEN.LBRACK.LESS") + | Parser.TOKEN_LBRACE -> getErrorString ("Parser.TOKEN.LBRACE") + | Parser.TOKEN_BAR_RBRACK -> getErrorString ("Parser.TOKEN.BAR.RBRACK") + | Parser.TOKEN_BAR_RBRACE -> getErrorString ("Parser.TOKEN.BAR.RBRACE") + | Parser.TOKEN_GREATER_RBRACK -> getErrorString ("Parser.TOKEN.GREATER.RBRACK") + | Parser.TOKEN_RQUOTE_DOT _ + | Parser.TOKEN_RQUOTE -> getErrorString ("Parser.TOKEN.RQUOTE") + | Parser.TOKEN_RBRACK -> getErrorString ("Parser.TOKEN.RBRACK") + | Parser.TOKEN_RBRACE + | Parser.TOKEN_RBRACE_COMING_SOON + | Parser.TOKEN_RBRACE_IS_HERE -> getErrorString ("Parser.TOKEN.RBRACE") + | Parser.TOKEN_PUBLIC -> getErrorString ("Parser.TOKEN.PUBLIC") + | Parser.TOKEN_PRIVATE -> getErrorString ("Parser.TOKEN.PRIVATE") + | Parser.TOKEN_INTERNAL -> getErrorString ("Parser.TOKEN.INTERNAL") + | Parser.TOKEN_CONSTRAINT -> getErrorString ("Parser.TOKEN.CONSTRAINT") + | Parser.TOKEN_INSTANCE -> getErrorString ("Parser.TOKEN.INSTANCE") + | Parser.TOKEN_DELEGATE -> getErrorString ("Parser.TOKEN.DELEGATE") + | Parser.TOKEN_INHERIT -> getErrorString ("Parser.TOKEN.INHERIT") + | Parser.TOKEN_CONSTRUCTOR -> getErrorString ("Parser.TOKEN.CONSTRUCTOR") + | Parser.TOKEN_DEFAULT -> getErrorString ("Parser.TOKEN.DEFAULT") + | Parser.TOKEN_OVERRIDE -> getErrorString ("Parser.TOKEN.OVERRIDE") + | Parser.TOKEN_ABSTRACT -> getErrorString ("Parser.TOKEN.ABSTRACT") + | Parser.TOKEN_CLASS -> getErrorString ("Parser.TOKEN.CLASS") + | Parser.TOKEN_MEMBER -> getErrorString ("Parser.TOKEN.MEMBER") + | Parser.TOKEN_STATIC -> getErrorString ("Parser.TOKEN.STATIC") + | Parser.TOKEN_NAMESPACE -> getErrorString ("Parser.TOKEN.NAMESPACE") + | Parser.TOKEN_OBLOCKBEGIN -> getErrorString ("Parser.TOKEN.OBLOCKBEGIN") + | EndOfStructuredConstructToken -> getErrorString ("Parser.TOKEN.OBLOCKEND") + | Parser.TOKEN_THEN + | Parser.TOKEN_OTHEN -> getErrorString ("Parser.TOKEN.OTHEN") + | Parser.TOKEN_ELSE + | Parser.TOKEN_OELSE -> getErrorString ("Parser.TOKEN.OELSE") + | Parser.TOKEN_LET _ + | Parser.TOKEN_OLET _ -> getErrorString ("Parser.TOKEN.OLET") + | Parser.TOKEN_OBINDER + | Parser.TOKEN_BINDER -> getErrorString ("Parser.TOKEN.BINDER") + | Parser.TOKEN_OAND_BANG + | Parser.TOKEN_AND_BANG -> getErrorString ("Parser.TOKEN.AND.BANG") + | Parser.TOKEN_ODO -> getErrorString ("Parser.TOKEN.ODO") + | Parser.TOKEN_OWITH -> getErrorString ("Parser.TOKEN.OWITH") + | Parser.TOKEN_OFUNCTION -> getErrorString ("Parser.TOKEN.OFUNCTION") + | Parser.TOKEN_OFUN -> getErrorString ("Parser.TOKEN.OFUN") + | Parser.TOKEN_ORESET -> getErrorString ("Parser.TOKEN.ORESET") + | Parser.TOKEN_ODUMMY -> getErrorString ("Parser.TOKEN.ODUMMY") + | Parser.TOKEN_DO_BANG + | Parser.TOKEN_ODO_BANG -> getErrorString ("Parser.TOKEN.ODO.BANG") + | Parser.TOKEN_YIELD -> getErrorString ("Parser.TOKEN.YIELD") + | Parser.TOKEN_YIELD_BANG -> getErrorString ("Parser.TOKEN.YIELD.BANG") + | Parser.TOKEN_OINTERFACE_MEMBER -> getErrorString ("Parser.TOKEN.OINTERFACE.MEMBER") + | Parser.TOKEN_ELIF -> getErrorString ("Parser.TOKEN.ELIF") + | Parser.TOKEN_RARROW -> getErrorString ("Parser.TOKEN.RARROW") + | Parser.TOKEN_SIG -> getErrorString ("Parser.TOKEN.SIG") + | Parser.TOKEN_STRUCT -> getErrorString ("Parser.TOKEN.STRUCT") + | Parser.TOKEN_UPCAST -> getErrorString ("Parser.TOKEN.UPCAST") + | Parser.TOKEN_DOWNCAST -> getErrorString ("Parser.TOKEN.DOWNCAST") + | Parser.TOKEN_NULL -> getErrorString ("Parser.TOKEN.NULL") + | Parser.TOKEN_RESERVED -> getErrorString ("Parser.TOKEN.RESERVED") + | Parser.TOKEN_MODULE + | Parser.TOKEN_MODULE_COMING_SOON + | Parser.TOKEN_MODULE_IS_HERE -> getErrorString ("Parser.TOKEN.MODULE") + | Parser.TOKEN_AND -> getErrorString ("Parser.TOKEN.AND") + | Parser.TOKEN_AS -> getErrorString ("Parser.TOKEN.AS") + | Parser.TOKEN_ASSERT -> getErrorString ("Parser.TOKEN.ASSERT") + | Parser.TOKEN_OASSERT -> getErrorString ("Parser.TOKEN.ASSERT") + | Parser.TOKEN_ASR -> getErrorString ("Parser.TOKEN.ASR") + | Parser.TOKEN_DOWNTO -> getErrorString ("Parser.TOKEN.DOWNTO") + | Parser.TOKEN_EXCEPTION -> getErrorString ("Parser.TOKEN.EXCEPTION") + | Parser.TOKEN_FALSE -> getErrorString ("Parser.TOKEN.FALSE") + | Parser.TOKEN_FOR -> getErrorString ("Parser.TOKEN.FOR") + | Parser.TOKEN_FUN -> getErrorString ("Parser.TOKEN.FUN") + | Parser.TOKEN_FUNCTION -> getErrorString ("Parser.TOKEN.FUNCTION") + | Parser.TOKEN_FINALLY -> getErrorString ("Parser.TOKEN.FINALLY") + | Parser.TOKEN_LAZY -> getErrorString ("Parser.TOKEN.LAZY") + | Parser.TOKEN_OLAZY -> getErrorString ("Parser.TOKEN.LAZY") + | Parser.TOKEN_MATCH -> getErrorString ("Parser.TOKEN.MATCH") + | Parser.TOKEN_MATCH_BANG -> getErrorString ("Parser.TOKEN.MATCH.BANG") + | Parser.TOKEN_MUTABLE -> getErrorString ("Parser.TOKEN.MUTABLE") + | Parser.TOKEN_NEW -> getErrorString ("Parser.TOKEN.NEW") + | Parser.TOKEN_OF -> getErrorString ("Parser.TOKEN.OF") + | Parser.TOKEN_OPEN -> getErrorString ("Parser.TOKEN.OPEN") + | Parser.TOKEN_OR -> getErrorString ("Parser.TOKEN.OR") + | Parser.TOKEN_VOID -> getErrorString ("Parser.TOKEN.VOID") + | Parser.TOKEN_EXTERN -> getErrorString ("Parser.TOKEN.EXTERN") + | Parser.TOKEN_INTERFACE -> getErrorString ("Parser.TOKEN.INTERFACE") + | Parser.TOKEN_REC -> getErrorString ("Parser.TOKEN.REC") + | Parser.TOKEN_TO -> getErrorString ("Parser.TOKEN.TO") + | Parser.TOKEN_TRUE -> getErrorString ("Parser.TOKEN.TRUE") + | Parser.TOKEN_TRY -> getErrorString ("Parser.TOKEN.TRY") + | Parser.TOKEN_TYPE + | Parser.TOKEN_TYPE_COMING_SOON + | Parser.TOKEN_TYPE_IS_HERE -> getErrorString ("Parser.TOKEN.TYPE") + | Parser.TOKEN_VAL -> getErrorString ("Parser.TOKEN.VAL") + | Parser.TOKEN_INLINE -> getErrorString ("Parser.TOKEN.INLINE") + | Parser.TOKEN_WHEN -> getErrorString ("Parser.TOKEN.WHEN") + | Parser.TOKEN_WHILE -> getErrorString ("Parser.TOKEN.WHILE") + | Parser.TOKEN_WITH -> getErrorString ("Parser.TOKEN.WITH") + | Parser.TOKEN_IF -> getErrorString ("Parser.TOKEN.IF") + | Parser.TOKEN_DO -> getErrorString ("Parser.TOKEN.DO") + | Parser.TOKEN_GLOBAL -> getErrorString ("Parser.TOKEN.GLOBAL") + | Parser.TOKEN_DONE -> getErrorString ("Parser.TOKEN.DONE") + | Parser.TOKEN_IN + | Parser.TOKEN_JOIN_IN -> getErrorString ("Parser.TOKEN.IN") + | Parser.TOKEN_HIGH_PRECEDENCE_PAREN_APP -> getErrorString ("Parser.TOKEN.HIGH.PRECEDENCE.PAREN.APP") + | Parser.TOKEN_HIGH_PRECEDENCE_BRACK_APP -> getErrorString ("Parser.TOKEN.HIGH.PRECEDENCE.BRACK.APP") + | Parser.TOKEN_BEGIN -> getErrorString ("Parser.TOKEN.BEGIN") + | Parser.TOKEN_END -> getErrorString ("Parser.TOKEN.END") + | Parser.TOKEN_HASH_LIGHT + | Parser.TOKEN_HASH_LINE + | Parser.TOKEN_HASH_IF + | Parser.TOKEN_HASH_ELSE + | Parser.TOKEN_HASH_ENDIF -> getErrorString ("Parser.TOKEN.HASH.ENDIF") + | Parser.TOKEN_INACTIVECODE -> getErrorString ("Parser.TOKEN.INACTIVECODE") + | Parser.TOKEN_LEX_FAILURE -> getErrorString ("Parser.TOKEN.LEX.FAILURE") + | Parser.TOKEN_WHITESPACE -> getErrorString ("Parser.TOKEN.WHITESPACE") + | Parser.TOKEN_COMMENT -> getErrorString ("Parser.TOKEN.COMMENT") + | Parser.TOKEN_LINE_COMMENT -> getErrorString ("Parser.TOKEN.LINE.COMMENT") + | Parser.TOKEN_STRING_TEXT -> getErrorString ("Parser.TOKEN.STRING.TEXT") + | Parser.TOKEN_BYTEARRAY -> getErrorString ("Parser.TOKEN.BYTEARRAY") + | Parser.TOKEN_STRING -> getErrorString ("Parser.TOKEN.STRING") + | Parser.TOKEN_KEYWORD_STRING -> getErrorString ("Parser.TOKEN.KEYWORD_STRING") + | Parser.TOKEN_EOF -> getErrorString ("Parser.TOKEN.EOF") + | Parser.TOKEN_CONST -> getErrorString ("Parser.TOKEN.CONST") + | Parser.TOKEN_FIXED -> getErrorString ("Parser.TOKEN.FIXED") + | Parser.TOKEN_INTERP_STRING_BEGIN_END -> getErrorString ("Parser.TOKEN.INTERP.STRING.BEGIN.END") + | Parser.TOKEN_INTERP_STRING_BEGIN_PART -> getErrorString ("Parser.TOKEN.INTERP.STRING.BEGIN.PART") + | Parser.TOKEN_INTERP_STRING_PART -> getErrorString ("Parser.TOKEN.INTERP.STRING.PART") + | Parser.TOKEN_INTERP_STRING_END -> getErrorString ("Parser.TOKEN.INTERP.STRING.END") + | unknown -> + Debug.Assert(false, "unknown token tag") + let result = sprintf "%+A" unknown + Debug.Assert(false, result) + result #if DEBUG - if showParserStackOnParseError then - printfn "parser stack:" - for rps in ctxt.ReducibleProductions do - printfn " ----" - //printfn " state %d" state - for rp in rps do - printfn " non-terminal %+A (idx %d): ... " (Parser.prodIdxToNonTerminal rp) rp + if showParserStackOnParseError then + printfn "parser stack:" + + for rps in ctxt.ReducibleProductions do + printfn " ----" + //printfn " state %d" state + for rp in rps do + printfn " non-terminal %+A (idx %d): ... " (Parser.prodIdxToNonTerminal rp) rp #endif - match ctxt.CurrentToken with - | None -> os.AppendString(UnexpectedEndOfInputE().Format) - | Some token -> - let tokenId = token |> Parser.tagOfToken |> Parser.tokenTagToTokenId - - match tokenId, token with - | EndOfStructuredConstructToken, _ -> os.AppendString(OBlockEndSentenceE().Format) - | Parser.TOKEN_LEX_FAILURE, Parser.LEX_FAILURE str -> os.AppendString str - | token, _ -> os.AppendString(UnexpectedE().Format (token |> tokenIdToText)) - - // Search for a state producing a single recognized non-terminal in the states on the stack - let foundInContext = - - // Merge a bunch of expression non terminals - let (|NONTERM_Category_Expr|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_argExpr|Parser.NONTERM_minusExpr|Parser.NONTERM_parenExpr|Parser.NONTERM_atomicExpr - | Parser.NONTERM_appExpr|Parser.NONTERM_tupleExpr|Parser.NONTERM_declExpr|Parser.NONTERM_braceExpr|Parser.NONTERM_braceBarExpr - | Parser.NONTERM_typedSequentialExprBlock - | Parser.NONTERM_interactiveExpr -> Some() - | _ -> None - - // Merge a bunch of pattern non terminals - let (|NONTERM_Category_Pattern|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_constrPattern|Parser.NONTERM_parenPattern|Parser.NONTERM_atomicPattern -> Some() - | _ -> None - - // Merge a bunch of if/then/else non terminals - let (|NONTERM_Category_IfThenElse|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_ifExprThen|Parser.NONTERM_ifExprElifs|Parser.NONTERM_ifExprCases -> Some() - | _ -> None - - // Merge a bunch of non terminals - let (|NONTERM_Category_SignatureFile|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_signatureFile|Parser.NONTERM_moduleSpfn|Parser.NONTERM_moduleSpfns -> Some() - | _ -> None - - let (|NONTERM_Category_ImplementationFile|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_implementationFile|Parser.NONTERM_fileNamespaceImpl|Parser.NONTERM_fileNamespaceImpls -> Some() - | _ -> None - - let (|NONTERM_Category_Definition|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_fileModuleImpl|Parser.NONTERM_moduleDefn|Parser.NONTERM_interactiveDefns - | Parser.NONTERM_moduleDefns|Parser.NONTERM_moduleDefnsOrExpr -> Some() - | _ -> None - - let (|NONTERM_Category_Type|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_typ|Parser.NONTERM_tupleType -> Some() - | _ -> None - - let (|NONTERM_Category_Interaction|_|) nonTerminal = - match nonTerminal with - | Parser.NONTERM_interactiveItemsTerminator|Parser.NONTERM_interaction|Parser.NONTERM__startinteraction -> Some() - | _ -> None - - // Canonicalize the categories and check for a unique category - ctxt.ReducibleProductions |> List.exists (fun prods -> - let prodIds = - prods - |> List.map Parser.prodIdxToNonTerminal - |> List.map (fun nonTerminal -> - match nonTerminal with - | NONTERM_Category_Type -> Parser.NONTERM_typ - | NONTERM_Category_Expr -> Parser.NONTERM_declExpr - | NONTERM_Category_Pattern -> Parser.NONTERM_atomicPattern - | NONTERM_Category_IfThenElse -> Parser.NONTERM_ifExprThen - | NONTERM_Category_SignatureFile -> Parser.NONTERM_signatureFile - | NONTERM_Category_ImplementationFile -> Parser.NONTERM_implementationFile - | NONTERM_Category_Definition -> Parser.NONTERM_moduleDefn - | NONTERM_Category_Interaction -> Parser.NONTERM_interaction - | nt -> nt) - |> Set.ofList - |> Set.toList - match prodIds with - | [Parser.NONTERM_interaction] -> os.AppendString(NONTERM_interactionE().Format); true - | [Parser.NONTERM_hashDirective] -> os.AppendString(NONTERM_hashDirectiveE().Format); true - | [Parser.NONTERM_fieldDecl] -> os.AppendString(NONTERM_fieldDeclE().Format); true - | [Parser.NONTERM_unionCaseRepr] -> os.AppendString(NONTERM_unionCaseReprE().Format); true - | [Parser.NONTERM_localBinding] -> os.AppendString(NONTERM_localBindingE().Format); true - | [Parser.NONTERM_hardwhiteLetBindings] -> os.AppendString(NONTERM_hardwhiteLetBindingsE().Format); true - | [Parser.NONTERM_classDefnMember] -> os.AppendString(NONTERM_classDefnMemberE().Format); true - | [Parser.NONTERM_defnBindings] -> os.AppendString(NONTERM_defnBindingsE().Format); true - | [Parser.NONTERM_classMemberSpfn] -> os.AppendString(NONTERM_classMemberSpfnE().Format); true - | [Parser.NONTERM_valSpfn] -> os.AppendString(NONTERM_valSpfnE().Format); true - | [Parser.NONTERM_tyconSpfn] -> os.AppendString(NONTERM_tyconSpfnE().Format); true - | [Parser.NONTERM_anonLambdaExpr] -> os.AppendString(NONTERM_anonLambdaExprE().Format); true - | [Parser.NONTERM_attrUnionCaseDecl] -> os.AppendString(NONTERM_attrUnionCaseDeclE().Format); true - | [Parser.NONTERM_cPrototype] -> os.AppendString(NONTERM_cPrototypeE().Format); true - | [Parser.NONTERM_objExpr|Parser.NONTERM_objectImplementationMembers] -> os.AppendString(NONTERM_objectImplementationMembersE().Format); true - | [Parser.NONTERM_ifExprThen|Parser.NONTERM_ifExprElifs|Parser.NONTERM_ifExprCases] -> os.AppendString(NONTERM_ifExprCasesE().Format); true - | [Parser.NONTERM_openDecl] -> os.AppendString(NONTERM_openDeclE().Format); true - | [Parser.NONTERM_fileModuleSpec] -> os.AppendString(NONTERM_fileModuleSpecE().Format); true - | [Parser.NONTERM_patternClauses] -> os.AppendString(NONTERM_patternClausesE().Format); true - | [Parser.NONTERM_beginEndExpr] -> os.AppendString(NONTERM_beginEndExprE().Format); true - | [Parser.NONTERM_recdExpr] -> os.AppendString(NONTERM_recdExprE().Format); true - | [Parser.NONTERM_tyconDefn] -> os.AppendString(NONTERM_tyconDefnE().Format); true - | [Parser.NONTERM_exconCore] -> os.AppendString(NONTERM_exconCoreE().Format); true - | [Parser.NONTERM_typeNameInfo] -> os.AppendString(NONTERM_typeNameInfoE().Format); true - | [Parser.NONTERM_attributeList] -> os.AppendString(NONTERM_attributeListE().Format); true - | [Parser.NONTERM_quoteExpr] -> os.AppendString(NONTERM_quoteExprE().Format); true - | [Parser.NONTERM_typeConstraint] -> os.AppendString(NONTERM_typeConstraintE().Format); true - | [NONTERM_Category_ImplementationFile] -> os.AppendString(NONTERM_Category_ImplementationFileE().Format); true - | [NONTERM_Category_Definition] -> os.AppendString(NONTERM_Category_DefinitionE().Format); true - | [NONTERM_Category_SignatureFile] -> os.AppendString(NONTERM_Category_SignatureFileE().Format); true - | [NONTERM_Category_Pattern] -> os.AppendString(NONTERM_Category_PatternE().Format); true - | [NONTERM_Category_Expr] -> os.AppendString(NONTERM_Category_ExprE().Format); true - | [NONTERM_Category_Type] -> os.AppendString(NONTERM_Category_TypeE().Format); true - | [Parser.NONTERM_typeArgsActual] -> os.AppendString(NONTERM_typeArgsActualE().Format); true - | _ -> - false) + match ctxt.CurrentToken with + | None -> os.AppendString(UnexpectedEndOfInputE().Format) + | Some token -> + let tokenId = token |> Parser.tagOfToken |> Parser.tokenTagToTokenId + + match tokenId, token with + | EndOfStructuredConstructToken, _ -> os.AppendString(OBlockEndSentenceE().Format) + | Parser.TOKEN_LEX_FAILURE, Parser.LEX_FAILURE str -> os.AppendString str + | token, _ -> os.AppendString(UnexpectedE().Format(token |> tokenIdToText)) + + // Search for a state producing a single recognized non-terminal in the states on the stack + let foundInContext = + + // Merge a bunch of expression non terminals + let (|NONTERM_Category_Expr|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_argExpr + | Parser.NONTERM_minusExpr + | Parser.NONTERM_parenExpr + | Parser.NONTERM_atomicExpr + | Parser.NONTERM_appExpr + | Parser.NONTERM_tupleExpr + | Parser.NONTERM_declExpr + | Parser.NONTERM_braceExpr + | Parser.NONTERM_braceBarExpr + | Parser.NONTERM_typedSequentialExprBlock + | Parser.NONTERM_interactiveExpr -> Some() + | _ -> None + + // Merge a bunch of pattern non terminals + let (|NONTERM_Category_Pattern|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_constrPattern + | Parser.NONTERM_parenPattern + | Parser.NONTERM_atomicPattern -> Some() + | _ -> None + + // Merge a bunch of if/then/else non terminals + let (|NONTERM_Category_IfThenElse|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_ifExprThen + | Parser.NONTERM_ifExprElifs + | Parser.NONTERM_ifExprCases -> Some() + | _ -> None + + // Merge a bunch of non terminals + let (|NONTERM_Category_SignatureFile|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_signatureFile + | Parser.NONTERM_moduleSpfn + | Parser.NONTERM_moduleSpfns -> Some() + | _ -> None + + let (|NONTERM_Category_ImplementationFile|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_implementationFile + | Parser.NONTERM_fileNamespaceImpl + | Parser.NONTERM_fileNamespaceImpls -> Some() + | _ -> None + + let (|NONTERM_Category_Definition|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_fileModuleImpl + | Parser.NONTERM_moduleDefn + | Parser.NONTERM_interactiveDefns + | Parser.NONTERM_moduleDefns + | Parser.NONTERM_moduleDefnsOrExpr -> Some() + | _ -> None + + let (|NONTERM_Category_Type|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_typ + | Parser.NONTERM_tupleType -> Some() + | _ -> None + + let (|NONTERM_Category_Interaction|_|) nonTerminal = + match nonTerminal with + | Parser.NONTERM_interactiveItemsTerminator + | Parser.NONTERM_interaction + | Parser.NONTERM__startinteraction -> Some() + | _ -> None + + // Canonicalize the categories and check for a unique category + ctxt.ReducibleProductions + |> List.exists (fun prods -> + let prodIds = + prods + |> List.map Parser.prodIdxToNonTerminal + |> List.map (fun nonTerminal -> + match nonTerminal with + | NONTERM_Category_Type -> Parser.NONTERM_typ + | NONTERM_Category_Expr -> Parser.NONTERM_declExpr + | NONTERM_Category_Pattern -> Parser.NONTERM_atomicPattern + | NONTERM_Category_IfThenElse -> Parser.NONTERM_ifExprThen + | NONTERM_Category_SignatureFile -> Parser.NONTERM_signatureFile + | NONTERM_Category_ImplementationFile -> Parser.NONTERM_implementationFile + | NONTERM_Category_Definition -> Parser.NONTERM_moduleDefn + | NONTERM_Category_Interaction -> Parser.NONTERM_interaction + | nt -> nt) + |> Set.ofList + |> Set.toList + + match prodIds with + | [ Parser.NONTERM_interaction ] -> + os.AppendString(NONTERM_interactionE().Format) + true + | [ Parser.NONTERM_hashDirective ] -> + os.AppendString(NONTERM_hashDirectiveE().Format) + true + | [ Parser.NONTERM_fieldDecl ] -> + os.AppendString(NONTERM_fieldDeclE().Format) + true + | [ Parser.NONTERM_unionCaseRepr ] -> + os.AppendString(NONTERM_unionCaseReprE().Format) + true + | [ Parser.NONTERM_localBinding ] -> + os.AppendString(NONTERM_localBindingE().Format) + true + | [ Parser.NONTERM_hardwhiteLetBindings ] -> + os.AppendString(NONTERM_hardwhiteLetBindingsE().Format) + true + | [ Parser.NONTERM_classDefnMember ] -> + os.AppendString(NONTERM_classDefnMemberE().Format) + true + | [ Parser.NONTERM_defnBindings ] -> + os.AppendString(NONTERM_defnBindingsE().Format) + true + | [ Parser.NONTERM_classMemberSpfn ] -> + os.AppendString(NONTERM_classMemberSpfnE().Format) + true + | [ Parser.NONTERM_valSpfn ] -> + os.AppendString(NONTERM_valSpfnE().Format) + true + | [ Parser.NONTERM_tyconSpfn ] -> + os.AppendString(NONTERM_tyconSpfnE().Format) + true + | [ Parser.NONTERM_anonLambdaExpr ] -> + os.AppendString(NONTERM_anonLambdaExprE().Format) + true + | [ Parser.NONTERM_attrUnionCaseDecl ] -> + os.AppendString(NONTERM_attrUnionCaseDeclE().Format) + true + | [ Parser.NONTERM_cPrototype ] -> + os.AppendString(NONTERM_cPrototypeE().Format) + true + | [ Parser.NONTERM_objExpr | Parser.NONTERM_objectImplementationMembers ] -> + os.AppendString(NONTERM_objectImplementationMembersE().Format) + true + | [ Parser.NONTERM_ifExprThen | Parser.NONTERM_ifExprElifs | Parser.NONTERM_ifExprCases ] -> + os.AppendString(NONTERM_ifExprCasesE().Format) + true + | [ Parser.NONTERM_openDecl ] -> + os.AppendString(NONTERM_openDeclE().Format) + true + | [ Parser.NONTERM_fileModuleSpec ] -> + os.AppendString(NONTERM_fileModuleSpecE().Format) + true + | [ Parser.NONTERM_patternClauses ] -> + os.AppendString(NONTERM_patternClausesE().Format) + true + | [ Parser.NONTERM_beginEndExpr ] -> + os.AppendString(NONTERM_beginEndExprE().Format) + true + | [ Parser.NONTERM_recdExpr ] -> + os.AppendString(NONTERM_recdExprE().Format) + true + | [ Parser.NONTERM_tyconDefn ] -> + os.AppendString(NONTERM_tyconDefnE().Format) + true + | [ Parser.NONTERM_exconCore ] -> + os.AppendString(NONTERM_exconCoreE().Format) + true + | [ Parser.NONTERM_typeNameInfo ] -> + os.AppendString(NONTERM_typeNameInfoE().Format) + true + | [ Parser.NONTERM_attributeList ] -> + os.AppendString(NONTERM_attributeListE().Format) + true + | [ Parser.NONTERM_quoteExpr ] -> + os.AppendString(NONTERM_quoteExprE().Format) + true + | [ Parser.NONTERM_typeConstraint ] -> + os.AppendString(NONTERM_typeConstraintE().Format) + true + | [ NONTERM_Category_ImplementationFile ] -> + os.AppendString(NONTERM_Category_ImplementationFileE().Format) + true + | [ NONTERM_Category_Definition ] -> + os.AppendString(NONTERM_Category_DefinitionE().Format) + true + | [ NONTERM_Category_SignatureFile ] -> + os.AppendString(NONTERM_Category_SignatureFileE().Format) + true + | [ NONTERM_Category_Pattern ] -> + os.AppendString(NONTERM_Category_PatternE().Format) + true + | [ NONTERM_Category_Expr ] -> + os.AppendString(NONTERM_Category_ExprE().Format) + true + | [ NONTERM_Category_Type ] -> + os.AppendString(NONTERM_Category_TypeE().Format) + true + | [ Parser.NONTERM_typeArgsActual ] -> + os.AppendString(NONTERM_typeArgsActualE().Format) + true + | _ -> false) #if DEBUG - if not foundInContext then - Printf.bprintf os ". (no 'in' context found: %+A)" (List.mapSquared Parser.prodIdxToNonTerminal ctxt.ReducibleProductions) + if not foundInContext then + Printf.bprintf + os + ". (no 'in' context found: %+A)" + (List.mapSquared Parser.prodIdxToNonTerminal ctxt.ReducibleProductions) #else - foundInContext |> ignore // suppress unused variable warning in RELEASE + foundInContext |> ignore // suppress unused variable warning in RELEASE #endif - let fix (s: string) = s.Replace(SR.GetString("FixKeyword"), "").Replace(SR.GetString("FixSymbol"), "").Replace(SR.GetString("FixReplace"), "") - let tokenNames = - ctxt.ShiftTokens - |> List.map Parser.tokenTagToTokenId - |> List.filter (function Parser.TOKEN_error | Parser.TOKEN_EOF -> false | _ -> true) - |> List.map tokenIdToText - |> Set.ofList - |> Set.toList - - match tokenNames with - | [tokenName1] -> os.AppendString(TokenName1E().Format (fix tokenName1)) - | [tokenName1;tokenName2] -> os.AppendString(TokenName1TokenName2E().Format (fix tokenName1) (fix tokenName2)) - | [tokenName1;tokenName2;tokenName3] -> os.AppendString(TokenName1TokenName2TokenName3E().Format (fix tokenName1) (fix tokenName2) (fix tokenName3)) - | _ -> () + let fix (s: string) = + s + .Replace(SR.GetString("FixKeyword"), "") + .Replace(SR.GetString("FixSymbol"), "") + .Replace(SR.GetString("FixReplace"), "") + + let tokenNames = + ctxt.ShiftTokens + |> List.map Parser.tokenTagToTokenId + |> List.filter (function + | Parser.TOKEN_error + | Parser.TOKEN_EOF -> false + | _ -> true) + |> List.map tokenIdToText + |> Set.ofList + |> Set.toList + + match tokenNames with + | [ tokenName1 ] -> os.AppendString(TokenName1E().Format(fix tokenName1)) + | [ tokenName1; tokenName2 ] -> os.AppendString(TokenName1TokenName2E().Format (fix tokenName1) (fix tokenName2)) + | [ tokenName1; tokenName2; tokenName3 ] -> + os.AppendString(TokenName1TokenName2TokenName3E().Format (fix tokenName1) (fix tokenName2) (fix tokenName3)) + | _ -> () (* Printf.bprintf os ".\n\n state = %A\n token = %A\n expect (shift) %A\n expect (reduce) %A\n prods=%A\n non terminals: %A" ctxt.StateStack @@ -1328,395 +1462,415 @@ let OutputPhasedErrorR (os: StringBuilder) (diagnostic: PhasedDiagnostic) (canSu (List.mapSquared Parser.prodIdxToNonTerminal ctxt.ReducibleProductions) *) - | RuntimeCoercionSourceSealed(denv, ty, _) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - if isTyparTy denv.g ty then - os.AppendString(RuntimeCoercionSourceSealed1E().Format (NicePrint.stringOfTy denv ty)) - else - os.AppendString(RuntimeCoercionSourceSealed2E().Format (NicePrint.stringOfTy denv ty)) - - | CoercionTargetSealed(denv, ty, _) -> - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty, _cxs= PrettyTypes.PrettifyType denv.g ty - os.AppendString(CoercionTargetSealedE().Format (NicePrint.stringOfTy denv ty)) - - | UpcastUnnecessary _ -> - os.AppendString(UpcastUnnecessaryE().Format) - - | TypeTestUnnecessary _ -> - os.AppendString(TypeTestUnnecessaryE().Format) - - | QuotationTranslator.IgnoringPartOfQuotedTermWarning (msg, _) -> - Printf.bprintf os "%s" msg - - | OverrideDoesntOverride(denv, impl, minfoVirtOpt, g, amap, m) -> - let sig1 = DispatchSlotChecking.FormatOverride denv impl - match minfoVirtOpt with - | None -> - os.AppendString(OverrideDoesntOverride1E().Format sig1) - | Some minfoVirt -> - // https://github.com/dotnet/fsharp/issues/35 - // Improve error message when attempting to override generic return type with unit: - // we need to check if unit was used as a type argument - let hasUnitTType_app (types: TType list) = - types |> List.exists (function - | TType_app (maybeUnit, [], _) -> - match maybeUnit.TypeAbbrev with - | Some ttype when isUnitTy g ttype -> true - | _ -> false - | _ -> false) - - match minfoVirt.ApparentEnclosingType with - | TType_app (tycon, tyargs, _) when tycon.IsFSharpInterfaceTycon && hasUnitTType_app tyargs -> - // match abstract member with 'unit' passed as generic argument - os.AppendString(OverrideDoesntOverride4E().Format sig1) - | _ -> - os.AppendString(OverrideDoesntOverride2E().Format sig1) - let sig2 = DispatchSlotChecking.FormatMethInfoSig g amap m denv minfoVirt - if sig1 <> sig2 then - os.AppendString(OverrideDoesntOverride3E().Format sig2) - - | UnionCaseWrongArguments (_, n1, n2, _) -> - os.AppendString(UnionCaseWrongArgumentsE().Format n2 n1) - - | UnionPatternsBindDifferentNames _ -> - os.AppendString(UnionPatternsBindDifferentNamesE().Format) - - | ValueNotContained (denv, infoReader, mref, implVal, sigVal, f) -> - let text1, text2 = NicePrint.minimalStringsOfTwoValues denv infoReader (mkLocalValRef implVal) (mkLocalValRef sigVal) - os.AppendString(f((fullDisplayTextOfModRef mref), text1, text2)) - - | UnionCaseNotContained (denv, infoReader, enclosingTycon, v1, v2, f) -> - let enclosingTcref = mkLocalEntityRef enclosingTycon - os.AppendString(f((NicePrint.stringOfUnionCase denv infoReader enclosingTcref v1), (NicePrint.stringOfUnionCase denv infoReader enclosingTcref v2))) - - | FSharpExceptionNotContained (denv, infoReader, v1, v2, f) -> - os.AppendString(f((NicePrint.stringOfExnDef denv infoReader (mkLocalEntityRef v1)), (NicePrint.stringOfExnDef denv infoReader (mkLocalEntityRef v2)))) - - | FieldNotContained (denv, infoReader, enclosingTycon, v1, v2, f) -> - let enclosingTcref = mkLocalEntityRef enclosingTycon - os.AppendString(f((NicePrint.stringOfRecdField denv infoReader enclosingTcref v1), (NicePrint.stringOfRecdField denv infoReader enclosingTcref v2))) - - | RequiredButNotSpecified (_, mref, k, name, _) -> - let nsb = StringBuilder() - name nsb; - os.AppendString(RequiredButNotSpecifiedE().Format (fullDisplayTextOfModRef mref) k (nsb.ToString())) - - | UseOfAddressOfOperator _ -> - os.AppendString(UseOfAddressOfOperatorE().Format) - - | DefensiveCopyWarning(s, _) -> os.AppendString(DefensiveCopyWarningE().Format s) - - | DeprecatedThreadStaticBindingWarning _ -> - os.AppendString(DeprecatedThreadStaticBindingWarningE().Format) - - | FunctionValueUnexpected (denv, ty, _) -> - let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let errorText = FunctionValueUnexpectedE().Format (NicePrint.stringOfTy denv ty) - os.AppendString errorText - - | UnitTypeExpected (denv, ty, _) -> - let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let warningText = UnitTypeExpectedE().Format (NicePrint.stringOfTy denv ty) - os.AppendString warningText - - | UnitTypeExpectedWithEquality (denv, ty, _) -> - let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let warningText = UnitTypeExpectedWithEqualityE().Format (NicePrint.stringOfTy denv ty) - os.AppendString warningText - - | UnitTypeExpectedWithPossiblePropertySetter (denv, ty, bindingName, propertyName, _) -> - let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let warningText = UnitTypeExpectedWithPossiblePropertySetterE().Format (NicePrint.stringOfTy denv ty) bindingName propertyName - os.AppendString warningText - - | UnitTypeExpectedWithPossibleAssignment (denv, ty, isAlreadyMutable, bindingName, _) -> - let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let warningText = - if isAlreadyMutable then - UnitTypeExpectedWithPossibleAssignmentToMutableE().Format (NicePrint.stringOfTy denv ty) bindingName + | RuntimeCoercionSourceSealed (denv, ty, _) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + + if isTyparTy denv.g ty then + os.AppendString(RuntimeCoercionSourceSealed1E().Format(NicePrint.stringOfTy denv ty)) else - UnitTypeExpectedWithPossibleAssignmentE().Format (NicePrint.stringOfTy denv ty) bindingName - os.AppendString warningText + os.AppendString(RuntimeCoercionSourceSealed2E().Format(NicePrint.stringOfTy denv ty)) + + | CoercionTargetSealed (denv, ty, _) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + os.AppendString(CoercionTargetSealedE().Format(NicePrint.stringOfTy denv ty)) + + | UpcastUnnecessary _ -> os.AppendString(UpcastUnnecessaryE().Format) + + | TypeTestUnnecessary _ -> os.AppendString(TypeTestUnnecessaryE().Format) + + | QuotationTranslator.IgnoringPartOfQuotedTermWarning (msg, _) -> Printf.bprintf os "%s" msg + + | OverrideDoesntOverride (denv, impl, minfoVirtOpt, g, amap, m) -> + let sig1 = DispatchSlotChecking.FormatOverride denv impl + + match minfoVirtOpt with + | None -> os.AppendString(OverrideDoesntOverride1E().Format sig1) + | Some minfoVirt -> + // https://github.com/dotnet/fsharp/issues/35 + // Improve error message when attempting to override generic return type with unit: + // we need to check if unit was used as a type argument + let hasUnitTType_app (types: TType list) = + types + |> List.exists (function + | TType_app (maybeUnit, [], _) -> + match maybeUnit.TypeAbbrev with + | Some ttype when isUnitTy g ttype -> true + | _ -> false + | _ -> false) + + match minfoVirt.ApparentEnclosingType with + | TType_app (tycon, tyargs, _) when tycon.IsFSharpInterfaceTycon && hasUnitTType_app tyargs -> + // match abstract member with 'unit' passed as generic argument + os.AppendString(OverrideDoesntOverride4E().Format sig1) + | _ -> + os.AppendString(OverrideDoesntOverride2E().Format sig1) + let sig2 = DispatchSlotChecking.FormatMethInfoSig g amap m denv minfoVirt + + if sig1 <> sig2 then + os.AppendString(OverrideDoesntOverride3E().Format sig2) + + | UnionCaseWrongArguments (_, n1, n2, _) -> os.AppendString(UnionCaseWrongArgumentsE().Format n2 n1) + + | UnionPatternsBindDifferentNames _ -> os.AppendString(UnionPatternsBindDifferentNamesE().Format) + + | ValueNotContained (denv, infoReader, mref, implVal, sigVal, f) -> + let text1, text2 = + NicePrint.minimalStringsOfTwoValues denv infoReader (mkLocalValRef implVal) (mkLocalValRef sigVal) + + os.AppendString(f ((fullDisplayTextOfModRef mref), text1, text2)) + + | UnionCaseNotContained (denv, infoReader, enclosingTycon, v1, v2, f) -> + let enclosingTcref = mkLocalEntityRef enclosingTycon + + os.AppendString( + f ( + (NicePrint.stringOfUnionCase denv infoReader enclosingTcref v1), + (NicePrint.stringOfUnionCase denv infoReader enclosingTcref v2) + ) + ) + + | FSharpExceptionNotContained (denv, infoReader, v1, v2, f) -> + os.AppendString( + f ( + (NicePrint.stringOfExnDef denv infoReader (mkLocalEntityRef v1)), + (NicePrint.stringOfExnDef denv infoReader (mkLocalEntityRef v2)) + ) + ) - | RecursiveUseCheckedAtRuntime _ -> - os.AppendString(RecursiveUseCheckedAtRuntimeE().Format) + | FieldNotContained (denv, infoReader, enclosingTycon, v1, v2, f) -> + let enclosingTcref = mkLocalEntityRef enclosingTycon - | LetRecUnsound (_, [v], _) -> - os.AppendString(LetRecUnsound1E().Format v.DisplayName) + os.AppendString( + f ( + (NicePrint.stringOfRecdField denv infoReader enclosingTcref v1), + (NicePrint.stringOfRecdField denv infoReader enclosingTcref v2) + ) + ) + + | RequiredButNotSpecified (_, mref, k, name, _) -> + let nsb = StringBuilder() + name nsb + os.AppendString(RequiredButNotSpecifiedE().Format (fullDisplayTextOfModRef mref) k (nsb.ToString())) + + | UseOfAddressOfOperator _ -> os.AppendString(UseOfAddressOfOperatorE().Format) + + | DefensiveCopyWarning (s, _) -> os.AppendString(DefensiveCopyWarningE().Format s) + + | DeprecatedThreadStaticBindingWarning _ -> os.AppendString(DeprecatedThreadStaticBindingWarningE().Format) + + | FunctionValueUnexpected (denv, ty, _) -> + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + let errorText = FunctionValueUnexpectedE().Format(NicePrint.stringOfTy denv ty) + os.AppendString errorText + + | UnitTypeExpected (denv, ty, _) -> + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + let warningText = UnitTypeExpectedE().Format(NicePrint.stringOfTy denv ty) + os.AppendString warningText + + | UnitTypeExpectedWithEquality (denv, ty, _) -> + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + + let warningText = + UnitTypeExpectedWithEqualityE().Format(NicePrint.stringOfTy denv ty) + + os.AppendString warningText + + | UnitTypeExpectedWithPossiblePropertySetter (denv, ty, bindingName, propertyName, _) -> + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + + let warningText = + UnitTypeExpectedWithPossiblePropertySetterE().Format (NicePrint.stringOfTy denv ty) bindingName propertyName + + os.AppendString warningText + + | UnitTypeExpectedWithPossibleAssignment (denv, ty, isAlreadyMutable, bindingName, _) -> + let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + + let warningText = + if isAlreadyMutable then + UnitTypeExpectedWithPossibleAssignmentToMutableE().Format (NicePrint.stringOfTy denv ty) bindingName + else + UnitTypeExpectedWithPossibleAssignmentE().Format (NicePrint.stringOfTy denv ty) bindingName + + os.AppendString warningText + + | RecursiveUseCheckedAtRuntime _ -> os.AppendString(RecursiveUseCheckedAtRuntimeE().Format) + + | LetRecUnsound (_, [ v ], _) -> os.AppendString(LetRecUnsound1E().Format v.DisplayName) + + | LetRecUnsound (_, path, _) -> + let bos = StringBuilder() - | LetRecUnsound (_, path, _) -> - let bos = StringBuilder() - (path.Tail @ [path.Head]) |> List.iter (fun (v: ValRef) -> bos.AppendString(LetRecUnsoundInnerE().Format v.DisplayName)) - os.AppendString(LetRecUnsound2E().Format (List.head path).DisplayName (bos.ToString())) + (path.Tail @ [ path.Head ]) + |> List.iter (fun (v: ValRef) -> bos.AppendString(LetRecUnsoundInnerE().Format v.DisplayName)) - | LetRecEvaluatedOutOfOrder (_, _, _, _) -> - os.AppendString(LetRecEvaluatedOutOfOrderE().Format) + os.AppendString(LetRecUnsound2E().Format (List.head path).DisplayName (bos.ToString())) - | LetRecCheckedAtRuntime _ -> - os.AppendString(LetRecCheckedAtRuntimeE().Format) + | LetRecEvaluatedOutOfOrder (_, _, _, _) -> os.AppendString(LetRecEvaluatedOutOfOrderE().Format) - | SelfRefObjCtor(false, _) -> - os.AppendString(SelfRefObjCtor1E().Format) + | LetRecCheckedAtRuntime _ -> os.AppendString(LetRecCheckedAtRuntimeE().Format) - | SelfRefObjCtor(true, _) -> - os.AppendString(SelfRefObjCtor2E().Format) + | SelfRefObjCtor (false, _) -> os.AppendString(SelfRefObjCtor1E().Format) - | VirtualAugmentationOnNullValuedType _ -> - os.AppendString(VirtualAugmentationOnNullValuedTypeE().Format) + | SelfRefObjCtor (true, _) -> os.AppendString(SelfRefObjCtor2E().Format) - | NonVirtualAugmentationOnNullValuedType _ -> - os.AppendString(NonVirtualAugmentationOnNullValuedTypeE().Format) + | VirtualAugmentationOnNullValuedType _ -> os.AppendString(VirtualAugmentationOnNullValuedTypeE().Format) - | NonUniqueInferredAbstractSlot(_, denv, bindnm, bvirt1, bvirt2, _) -> - os.AppendString(NonUniqueInferredAbstractSlot1E().Format bindnm) - let ty1 = bvirt1.ApparentEnclosingType - let ty2 = bvirt2.ApparentEnclosingType - // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(NonUniqueInferredAbstractSlot2E().Format) - if ty1 <> ty2 then - os.AppendString(NonUniqueInferredAbstractSlot3E().Format ty1 ty2) - os.AppendString(NonUniqueInferredAbstractSlot4E().Format) + | NonVirtualAugmentationOnNullValuedType _ -> os.AppendString(NonVirtualAugmentationOnNullValuedTypeE().Format) - | DiagnosticWithText (_, s, _) -> os.AppendString s + | NonUniqueInferredAbstractSlot (_, denv, bindnm, bvirt1, bvirt2, _) -> + os.AppendString(NonUniqueInferredAbstractSlot1E().Format bindnm) + let ty1 = bvirt1.ApparentEnclosingType + let ty2 = bvirt2.ApparentEnclosingType + // REVIEW: consider if we need to show _cxs (the type parameter constraints) + let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + os.AppendString(NonUniqueInferredAbstractSlot2E().Format) - | DiagnosticWithSuggestions (_, s, _, idText, suggestionF) -> - os.AppendString(DecompileOpName s) - suggestNames suggestionF idText + if ty1 <> ty2 then + os.AppendString(NonUniqueInferredAbstractSlot3E().Format ty1 ty2) - | InternalError (s, _) + os.AppendString(NonUniqueInferredAbstractSlot4E().Format) - | InvalidArgument s + | DiagnosticWithText (_, s, _) -> os.AppendString s - | Failure s as exn -> - ignore exn // use the argument, even in non DEBUG - let f1 = SR.GetString("Failure1") - let f2 = SR.GetString("Failure2") - match s with - | f when f = f1 -> os.AppendString(Failure3E().Format s) - | f when f = f2 -> os.AppendString(Failure3E().Format s) - | _ -> os.AppendString(Failure4E().Format s) + | DiagnosticWithSuggestions (_, s, _, idText, suggestionF) -> + os.AppendString(DecompileOpName s) + suggestNames suggestionF idText + + | InternalError (s, _) + + | InvalidArgument s + + | Failure s as exn -> + ignore exn // use the argument, even in non DEBUG + let f1 = SR.GetString("Failure1") + let f2 = SR.GetString("Failure2") + + match s with + | f when f = f1 -> os.AppendString(Failure3E().Format s) + | f when f = f2 -> os.AppendString(Failure3E().Format s) + | _ -> os.AppendString(Failure4E().Format s) #if DEBUG - Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) - Debug.Assert(false, sprintf "Unexpected exception seen in compiler: %s\n%s" s (exn.ToString())) + Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) + Debug.Assert(false, sprintf "Unexpected exception seen in compiler: %s\n%s" s (exn.ToString())) #endif - | WrappedError (exn, _) -> OutputExceptionR os exn + | WrappedError (exn, _) -> OutputExceptionR os exn + + | PatternMatchCompilation.MatchIncomplete (isComp, cexOpt, _) -> + os.AppendString(MatchIncomplete1E().Format) - | PatternMatchCompilation.MatchIncomplete (isComp, cexOpt, _) -> - os.AppendString(MatchIncomplete1E().Format) - match cexOpt with - | None -> () - | Some (cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) - | Some (cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) - if isComp then - os.AppendString(MatchIncomplete4E().Format) + match cexOpt with + | None -> () + | Some (cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) + | Some (cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) - | PatternMatchCompilation.EnumMatchIncomplete (isComp, cexOpt, _) -> - os.AppendString(EnumMatchIncomplete1E().Format) - match cexOpt with - | None -> () - | Some (cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) - | Some (cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) - if isComp then - os.AppendString(MatchIncomplete4E().Format) + if isComp then os.AppendString(MatchIncomplete4E().Format) - | PatternMatchCompilation.RuleNeverMatched _ -> os.AppendString(RuleNeverMatchedE().Format) + | PatternMatchCompilation.EnumMatchIncomplete (isComp, cexOpt, _) -> + os.AppendString(EnumMatchIncomplete1E().Format) - | ValNotMutable(_, valRef, _) -> os.AppendString(ValNotMutableE().Format(valRef.DisplayName)) + match cexOpt with + | None -> () + | Some (cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) + | Some (cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) - | ValNotLocal _ -> os.AppendString(ValNotLocalE().Format) + if isComp then os.AppendString(MatchIncomplete4E().Format) - | ObsoleteError (s, _) + | PatternMatchCompilation.RuleNeverMatched _ -> os.AppendString(RuleNeverMatchedE().Format) - | ObsoleteWarning (s, _) -> + | ValNotMutable (_, valRef, _) -> os.AppendString(ValNotMutableE().Format(valRef.DisplayName)) + + | ValNotLocal _ -> os.AppendString(ValNotLocalE().Format) + + | ObsoleteError (s, _) + + | ObsoleteWarning (s, _) -> os.AppendString(Obsolete1E().Format) if s <> "" then os.AppendString(Obsolete2E().Format s) - | Experimental (s, _) -> os.AppendString(ExperimentalE().Format s) - - | PossibleUnverifiableCode _ -> os.AppendString(PossibleUnverifiableCodeE().Format) - - | UserCompilerMessage (msg, _, _) -> os.AppendString msg - - | Deprecated(s, _) -> os.AppendString(DeprecatedE().Format s) - - | LibraryUseOnly _ -> os.AppendString(LibraryUseOnlyE().Format) - - | MissingFields(sl, _) -> os.AppendString(MissingFieldsE().Format (String.concat "," sl + ".")) - - | ValueRestriction(denv, infoReader, hasSig, v, _, _) -> - let denv = { denv with showInferenceTyparAnnotations=true } - let tau = v.TauType - if hasSig then - if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then - let msg = - ValueRestriction1E().Format - v.DisplayName - (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) - v.DisplayName - os.AppendString msg - else - let msg = - ValueRestriction2E().Format - v.DisplayName - (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) - v.DisplayName - os.AppendString msg - else - match v.MemberInfo with - | Some membInfo when - (match membInfo.MemberFlags.MemberKind with - | SynMemberKind.PropertyGet - | SynMemberKind.PropertySet - | SynMemberKind.Constructor -> true // can't infer extra polymorphism - // can infer extra polymorphism - | _ -> false) -> - let msg = ValueRestriction3E().Format (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) - os.AppendString msg - | _ -> + | Experimental (s, _) -> os.AppendString(ExperimentalE().Format s) + + | PossibleUnverifiableCode _ -> os.AppendString(PossibleUnverifiableCodeE().Format) + + | UserCompilerMessage (msg, _, _) -> os.AppendString msg + + | Deprecated (s, _) -> os.AppendString(DeprecatedE().Format s) + + | LibraryUseOnly _ -> os.AppendString(LibraryUseOnlyE().Format) + + | MissingFields (sl, _) -> os.AppendString(MissingFieldsE().Format(String.concat "," sl + ".")) + + | ValueRestriction (denv, infoReader, hasSig, v, _, _) -> + let denv = + { denv with + showInferenceTyparAnnotations = true + } + + let tau = v.TauType + + if hasSig then if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then let msg = - ValueRestriction4E().Format + ValueRestriction1E().Format v.DisplayName (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) v.DisplayName + os.AppendString msg else let msg = - ValueRestriction5E().Format + ValueRestriction2E().Format v.DisplayName (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) v.DisplayName + + os.AppendString msg + else + match v.MemberInfo with + | Some membInfo when + (match membInfo.MemberFlags.MemberKind with + | SynMemberKind.PropertyGet + | SynMemberKind.PropertySet + | SynMemberKind.Constructor -> true // can't infer extra polymorphism + // can infer extra polymorphism + | _ -> false) + -> + let msg = + ValueRestriction3E() + .Format(NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) + os.AppendString msg + | _ -> + if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then + let msg = + ValueRestriction4E().Format + v.DisplayName + (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) + v.DisplayName + + os.AppendString msg + else + let msg = + ValueRestriction5E().Format + v.DisplayName + (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) + v.DisplayName - | Parsing.RecoverableParseError -> - os.AppendString(RecoverableParseErrorE().Format) + os.AppendString msg - | ReservedKeyword (s, _) -> - os.AppendString(ReservedKeywordE().Format s) + | Parsing.RecoverableParseError -> os.AppendString(RecoverableParseErrorE().Format) - | IndentationProblem (s, _) -> - os.AppendString(IndentationProblemE().Format s) + | ReservedKeyword (s, _) -> os.AppendString(ReservedKeywordE().Format s) - | OverrideInIntrinsicAugmentation _ -> - os.AppendString(OverrideInIntrinsicAugmentationE().Format) + | IndentationProblem (s, _) -> os.AppendString(IndentationProblemE().Format s) - | OverrideInExtrinsicAugmentation _ -> - os.AppendString(OverrideInExtrinsicAugmentationE().Format) + | OverrideInIntrinsicAugmentation _ -> os.AppendString(OverrideInIntrinsicAugmentationE().Format) - | IntfImplInIntrinsicAugmentation _ -> - os.AppendString(IntfImplInIntrinsicAugmentationE().Format) + | OverrideInExtrinsicAugmentation _ -> os.AppendString(OverrideInExtrinsicAugmentationE().Format) - | IntfImplInExtrinsicAugmentation _ -> - os.AppendString(IntfImplInExtrinsicAugmentationE().Format) + | IntfImplInIntrinsicAugmentation _ -> os.AppendString(IntfImplInIntrinsicAugmentationE().Format) - | UnresolvedReferenceError(assemblyName, _) - | UnresolvedReferenceNoRange assemblyName -> - os.AppendString(UnresolvedReferenceNoRangeE().Format assemblyName) + | IntfImplInExtrinsicAugmentation _ -> os.AppendString(IntfImplInExtrinsicAugmentationE().Format) - | UnresolvedPathReference(assemblyName, pathname, _) + | UnresolvedReferenceError (assemblyName, _) + | UnresolvedReferenceNoRange assemblyName -> os.AppendString(UnresolvedReferenceNoRangeE().Format assemblyName) - | UnresolvedPathReferenceNoRange(assemblyName, pathname) -> - os.AppendString(UnresolvedPathReferenceNoRangeE().Format pathname assemblyName) + | UnresolvedPathReference (assemblyName, pathname, _) - | DeprecatedCommandLineOptionFull(fullText, _) -> - os.AppendString fullText + | UnresolvedPathReferenceNoRange (assemblyName, pathname) -> + os.AppendString(UnresolvedPathReferenceNoRangeE().Format pathname assemblyName) - | DeprecatedCommandLineOptionForHtmlDoc(optionName, _) -> - os.AppendString(FSComp.SR.optsDCLOHtmlDoc optionName) + | DeprecatedCommandLineOptionFull (fullText, _) -> os.AppendString fullText - | DeprecatedCommandLineOptionSuggestAlternative(optionName, altOption, _) -> - os.AppendString(FSComp.SR.optsDCLODeprecatedSuggestAlternative(optionName, altOption)) + | DeprecatedCommandLineOptionForHtmlDoc (optionName, _) -> os.AppendString(FSComp.SR.optsDCLOHtmlDoc optionName) - | InternalCommandLineOption(optionName, _) -> - os.AppendString(FSComp.SR.optsInternalNoDescription optionName) + | DeprecatedCommandLineOptionSuggestAlternative (optionName, altOption, _) -> + os.AppendString(FSComp.SR.optsDCLODeprecatedSuggestAlternative (optionName, altOption)) - | DeprecatedCommandLineOptionNoDescription(optionName, _) -> - os.AppendString(FSComp.SR.optsDCLONoDescription optionName) + | InternalCommandLineOption (optionName, _) -> os.AppendString(FSComp.SR.optsInternalNoDescription optionName) - | HashIncludeNotAllowedInNonScript _ -> - os.AppendString(HashIncludeNotAllowedInNonScriptE().Format) + | DeprecatedCommandLineOptionNoDescription (optionName, _) -> os.AppendString(FSComp.SR.optsDCLONoDescription optionName) - | HashReferenceNotAllowedInNonScript _ -> - os.AppendString(HashReferenceNotAllowedInNonScriptE().Format) + | HashIncludeNotAllowedInNonScript _ -> os.AppendString(HashIncludeNotAllowedInNonScriptE().Format) - | HashDirectiveNotAllowedInNonScript _ -> - os.AppendString(HashDirectiveNotAllowedInNonScriptE().Format) + | HashReferenceNotAllowedInNonScript _ -> os.AppendString(HashReferenceNotAllowedInNonScriptE().Format) - | FileNameNotResolved(fileName, locations, _) -> - os.AppendString(FileNameNotResolvedE().Format fileName locations) + | HashDirectiveNotAllowedInNonScript _ -> os.AppendString(HashDirectiveNotAllowedInNonScriptE().Format) - | AssemblyNotResolved(originalName, _) -> - os.AppendString(AssemblyNotResolvedE().Format originalName) + | FileNameNotResolved (fileName, locations, _) -> os.AppendString(FileNameNotResolvedE().Format fileName locations) - | IllegalFileNameChar(fileName, invalidChar) -> - os.AppendString(FSComp.SR.buildUnexpectedFileNameCharacter(fileName, string invalidChar)|>snd) + | AssemblyNotResolved (originalName, _) -> os.AppendString(AssemblyNotResolvedE().Format originalName) - | HashLoadedSourceHasIssues(infos, warnings, errors, _) -> - let Emit(l: exn list) = - OutputExceptionR os (List.head l) - if isNil warnings && isNil errors then - os.AppendString(HashLoadedSourceHasIssues0E().Format) - Emit infos - elif isNil errors then - os.AppendString(HashLoadedSourceHasIssues1E().Format) - Emit warnings - else - os.AppendString(HashLoadedSourceHasIssues2E().Format) - Emit errors + | IllegalFileNameChar (fileName, invalidChar) -> + os.AppendString(FSComp.SR.buildUnexpectedFileNameCharacter (fileName, string invalidChar) |> snd) - | HashLoadedScriptConsideredSource _ -> - os.AppendString(HashLoadedScriptConsideredSourceE().Format) + | HashLoadedSourceHasIssues (infos, warnings, errors, _) -> + let Emit (l: exn list) = OutputExceptionR os (List.head l) - | InvalidInternalsVisibleToAssemblyName(badName, fileNameOption) -> - match fileNameOption with - | Some file -> os.AppendString(InvalidInternalsVisibleToAssemblyName1E().Format badName file) - | None -> os.AppendString(InvalidInternalsVisibleToAssemblyName2E().Format badName) + if isNil warnings && isNil errors then + os.AppendString(HashLoadedSourceHasIssues0E().Format) + Emit infos + elif isNil errors then + os.AppendString(HashLoadedSourceHasIssues1E().Format) + Emit warnings + else + os.AppendString(HashLoadedSourceHasIssues2E().Format) + Emit errors + + | HashLoadedScriptConsideredSource _ -> os.AppendString(HashLoadedScriptConsideredSourceE().Format) + + | InvalidInternalsVisibleToAssemblyName (badName, fileNameOption) -> + match fileNameOption with + | Some file -> os.AppendString(InvalidInternalsVisibleToAssemblyName1E().Format badName file) + | None -> os.AppendString(InvalidInternalsVisibleToAssemblyName2E().Format badName) - | LoadedSourceNotFoundIgnoring(fileName, _) -> - os.AppendString(LoadedSourceNotFoundIgnoringE().Format fileName) + | LoadedSourceNotFoundIgnoring (fileName, _) -> os.AppendString(LoadedSourceNotFoundIgnoringE().Format fileName) - | MSBuildReferenceResolutionWarning(code, message, _) + | MSBuildReferenceResolutionWarning (code, message, _) - | MSBuildReferenceResolutionError(code, message, _) -> - os.AppendString(MSBuildReferenceResolutionErrorE().Format message code) + | MSBuildReferenceResolutionError (code, message, _) -> os.AppendString(MSBuildReferenceResolutionErrorE().Format message code) - // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as exn -> - OutputExceptionR os exn.InnerException + // Strip TargetInvocationException wrappers + | :? System.Reflection.TargetInvocationException as exn -> OutputExceptionR os exn.InnerException - | :? FileNotFoundException as exn -> Printf.bprintf os "%s" exn.Message + | :? FileNotFoundException as exn -> Printf.bprintf os "%s" exn.Message - | :? DirectoryNotFoundException as exn -> Printf.bprintf os "%s" exn.Message + | :? DirectoryNotFoundException as exn -> Printf.bprintf os "%s" exn.Message - | :? ArgumentException as exn -> Printf.bprintf os "%s" exn.Message + | :? ArgumentException as exn -> Printf.bprintf os "%s" exn.Message - | :? NotSupportedException as exn -> Printf.bprintf os "%s" exn.Message + | :? NotSupportedException as exn -> Printf.bprintf os "%s" exn.Message - | :? IOException as exn -> Printf.bprintf os "%s" exn.Message + | :? IOException as exn -> Printf.bprintf os "%s" exn.Message - | :? UnauthorizedAccessException as exn -> Printf.bprintf os "%s" exn.Message + | :? UnauthorizedAccessException as exn -> Printf.bprintf os "%s" exn.Message - | exn -> - os.AppendString(TargetInvocationExceptionWrapperE().Format exn.Message) + | exn -> + os.AppendString(TargetInvocationExceptionWrapperE().Format exn.Message) #if DEBUG - Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) - if showAssertForUnexpectedException.Value then - Debug.Assert(false, sprintf "Unknown exception seen in compiler: %s" (exn.ToString())) + Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) + + if showAssertForUnexpectedException.Value then + Debug.Assert(false, sprintf "Unknown exception seen in compiler: %s" (exn.ToString())) #endif OutputExceptionR os diagnostic.Exception - // remove any newlines and tabs let OutputPhasedDiagnostic (os: StringBuilder) (diagnostic: PhasedDiagnostic) (flattenErrors: bool) (suggestNames: bool) = let buf = StringBuilder() OutputPhasedErrorR buf diagnostic suggestNames - let text = if flattenErrors then NormalizeErrorString (buf.ToString()) else buf.ToString() + + let text = + if flattenErrors then + NormalizeErrorString(buf.ToString()) + else + buf.ToString() os.AppendString text @@ -1731,32 +1885,38 @@ let SanitizeFileName fileName implicitIncludeDir = let currentDir = implicitIncludeDir // if the file name is not rooted in the current directory, return the full path - if not(fullPath.StartsWithOrdinal currentDir) then + if not (fullPath.StartsWithOrdinal currentDir) then fullPath // if the file name is rooted in the current directory, return the relative path else - fullPath.Replace(currentDir+"\\", "") + fullPath.Replace(currentDir + "\\", "") with _ -> fileName [] type FormattedDiagnosticLocation = - { Range: range - File: string - TextRepresentation: string - IsEmpty: bool } + { + Range: range + File: string + TextRepresentation: string + IsEmpty: bool + } [] type FormattedDiagnosticCanonicalInformation = - { ErrorNumber: int - Subcategory: string - TextRepresentation: string } + { + ErrorNumber: int + Subcategory: string + TextRepresentation: string + } [] type FormattedDiagnosticDetailedInfo = - { Location: FormattedDiagnosticLocation option - Canonical: FormattedDiagnosticCanonicalInformation - Message: string } + { + Location: FormattedDiagnosticLocation option + Canonical: FormattedDiagnosticCanonicalInformation + Message: string + } [] type FormattedDiagnostic = @@ -1764,120 +1924,180 @@ type FormattedDiagnostic = | Long of FSharpDiagnosticSeverity * FormattedDiagnosticDetailedInfo /// returns sequence that contains Diagnostic for the given error + Diagnostic for all related errors -let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity: FSharpDiagnosticSeverity, diagnostic: PhasedDiagnostic, suggestNames: bool) = - let outputWhere (showFullPaths, diagnosticStyle) m: FormattedDiagnosticLocation = +let CollectFormattedDiagnostics + ( + implicitIncludeDir, + showFullPaths, + flattenErrors, + diagnosticStyle, + severity: FSharpDiagnosticSeverity, + diagnostic: PhasedDiagnostic, + suggestNames: bool + ) = + let outputWhere (showFullPaths, diagnosticStyle) m : FormattedDiagnosticLocation = if equals m rangeStartup || equals m rangeCmdArgs then - { Range = m; TextRepresentation = ""; IsEmpty = true; File = "" } + { + Range = m + TextRepresentation = "" + IsEmpty = true + File = "" + } else let file = m.FileName - let file = if showFullPaths then - FileSystem.GetFullFilePathInDirectoryShim implicitIncludeDir file - else - SanitizeFileName file implicitIncludeDir + + let file = + if showFullPaths then + FileSystem.GetFullFilePathInDirectoryShim implicitIncludeDir file + else + SanitizeFileName file implicitIncludeDir + let text, m, file = match diagnosticStyle with - | DiagnosticStyle.Emacs -> + | DiagnosticStyle.Emacs -> let file = file.Replace("\\", "/") (sprintf "File \"%s\", line %d, characters %d-%d: " file m.StartLine m.StartColumn m.EndColumn), m, file - // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output - | DiagnosticStyle.Default -> + // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output + | DiagnosticStyle.Default -> let file = file.Replace('/', Path.DirectorySeparatorChar) let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) m.End (sprintf "%s(%d,%d): " file m.StartLine m.StartColumn), m, file - // We may also want to change Test to be 1-based - | DiagnosticStyle.Test -> + // We may also want to change Test to be 1-based + | DiagnosticStyle.Test -> let file = file.Replace("/", "\\") - let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) ) + + let m = + mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1)) + sprintf "%s(%d,%d-%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file - | DiagnosticStyle.Gcc -> + | DiagnosticStyle.Gcc -> let file = file.Replace('/', Path.DirectorySeparatorChar) - let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) ) + + let m = + mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1)) + sprintf "%s:%d:%d: " file m.StartLine m.StartColumn, m, file - // Here, we want the complete range information so Project Systems can generate proper squiggles - | DiagnosticStyle.VisualStudio -> - // Show prefix only for real files. Otherwise, we just want a truncated error like: - // parse error FS0031: blah blah - if not (equals m range0) && not (equals m rangeStartup) && not (equals m rangeCmdArgs) then - let file = file.Replace("/", "\\") - let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) ) - sprintf "%s(%d,%d,%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file - else - "", m, file - { Range = m; TextRepresentation = text; IsEmpty = false; File = file } + // Here, we want the complete range information so Project Systems can generate proper squiggles + | DiagnosticStyle.VisualStudio -> + // Show prefix only for real files. Otherwise, we just want a truncated error like: + // parse error FS0031: blah blah + if + not (equals m range0) && not (equals m rangeStartup) + && not (equals m rangeCmdArgs) + then + let file = file.Replace("/", "\\") + + let m = + mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1)) + + sprintf "%s(%d,%d,%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file + else + "", m, file + + { + Range = m + TextRepresentation = text + IsEmpty = false + File = file + } match diagnostic.Exception with | ReportedError _ -> assert ("" = "Unexpected ReportedError") // this should never happen - [| |] + [||] | StopProcessing -> assert ("" = "Unexpected StopProcessing") // this should never happen - [| |] + [||] | _ -> let errors = ResizeArray() + let report diagnostic = let OutputWhere diagnostic = match GetRangeOfDiagnostic diagnostic with | Some m -> Some(outputWhere (showFullPaths, diagnosticStyle) m) | None -> None - let OutputCanonicalInformation(subcategory, errorNumber) : FormattedDiagnosticCanonicalInformation = + let OutputCanonicalInformation (subcategory, errorNumber) : FormattedDiagnosticCanonicalInformation = let message = match severity with | FSharpDiagnosticSeverity.Error -> "error" | FSharpDiagnosticSeverity.Warning -> "warning" | FSharpDiagnosticSeverity.Info | FSharpDiagnosticSeverity.Hidden -> "info" + let text = match diagnosticStyle with // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness. | DiagnosticStyle.VisualStudio -> sprintf "%s %s FS%04d: " subcategory message errorNumber | _ -> sprintf "%s FS%04d: " message errorNumber - { ErrorNumber = errorNumber; Subcategory = subcategory; TextRepresentation = text} + + { + ErrorNumber = errorNumber + Subcategory = subcategory + TextRepresentation = text + } let mainError, relatedErrors = SplitRelatedDiagnostics diagnostic let where = OutputWhere mainError - let canonical = OutputCanonicalInformation(diagnostic.Subcategory(), GetDiagnosticNumber mainError) + + let canonical = + OutputCanonicalInformation(diagnostic.Subcategory(), GetDiagnosticNumber mainError) + let message = let os = StringBuilder() OutputPhasedDiagnostic os mainError flattenErrors suggestNames os.ToString() - let entry: FormattedDiagnosticDetailedInfo = { Location = where; Canonical = canonical; Message = message } + let entry: FormattedDiagnosticDetailedInfo = + { + Location = where + Canonical = canonical + Message = message + } - errors.Add (FormattedDiagnostic.Long(severity, entry)) + errors.Add(FormattedDiagnostic.Long(severity, entry)) - let OutputRelatedError(diagnostic: PhasedDiagnostic) = + let OutputRelatedError (diagnostic: PhasedDiagnostic) = match diagnosticStyle with // Give a canonical string when --vserror. | DiagnosticStyle.VisualStudio -> let relWhere = OutputWhere mainError // mainError? - let relCanonical = OutputCanonicalInformation(diagnostic.Subcategory(), GetDiagnosticNumber mainError) // Use main error for code + + let relCanonical = + OutputCanonicalInformation(diagnostic.Subcategory(), GetDiagnosticNumber mainError) // Use main error for code + let relMessage = let os = StringBuilder() OutputPhasedDiagnostic os diagnostic flattenErrors suggestNames os.ToString() - let entry: FormattedDiagnosticDetailedInfo = { Location = relWhere; Canonical = relCanonical; Message = relMessage} - errors.Add (FormattedDiagnostic.Long (severity, entry) ) + let entry: FormattedDiagnosticDetailedInfo = + { + Location = relWhere + Canonical = relCanonical + Message = relMessage + } + + errors.Add(FormattedDiagnostic.Long(severity, entry)) | _ -> let os = StringBuilder() OutputPhasedDiagnostic os diagnostic flattenErrors suggestNames - errors.Add (FormattedDiagnostic.Short(severity, os.ToString()) ) + errors.Add(FormattedDiagnostic.Short(severity, os.ToString())) relatedErrors |> List.iter OutputRelatedError match diagnostic with #if !NO_TYPEPROVIDERS - | {Exception = :? TypeProviderError as tpe} -> - tpe.Iter (fun exn -> - let newErr = {diagnostic with Exception = exn} - report newErr - ) + | { + Exception = :? TypeProviderError as tpe + } -> + tpe.Iter(fun exn -> + let newErr = { diagnostic with Exception = exn } + report newErr) #endif | x -> report x @@ -1888,16 +2108,19 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError let rec OutputDiagnostic (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity) os (diagnostic: PhasedDiagnostic) = // 'true' for "canSuggestNames" is passed last here because we want to report suggestions in fsc.exe and fsi.exe, just not in regular IDE usage. - let errors = CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity, diagnostic, true) + let errors = + CollectFormattedDiagnostics(implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity, diagnostic, true) + for e in errors do Printf.bprintf os "\n" + match e with - | FormattedDiagnostic.Short(_, txt) -> - os.AppendString txt |> ignore - | FormattedDiagnostic.Long(_, details) -> + | FormattedDiagnostic.Short (_, txt) -> os.AppendString txt |> ignore + | FormattedDiagnostic.Long (_, details) -> match details.Location with | Some l when not l.IsEmpty -> os.AppendString l.TextRepresentation | _ -> () + os.AppendString details.Canonical.TextRepresentation os.AppendString details.Message @@ -1909,7 +2132,8 @@ let OutputDiagnosticContext prefix fileLineFunction os diagnostic = let lineA = m.StartLine let lineB = m.EndLine let line = fileLineFunction fileName lineA - if line<>"" then + + if line <> "" then let iA = m.StartColumn let iB = m.EndColumn let iLen = if lineA = lineB then max (iB - iA) 1 else 1 @@ -1922,8 +2146,9 @@ let ReportDiagnosticAsInfo options (diagnostic, severity) = | FSharpDiagnosticSeverity.Warning -> false | FSharpDiagnosticSeverity.Info -> let n = GetDiagnosticNumber diagnostic - IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn && - not (List.contains n options.WarnOff) + + IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn + && not (List.contains n options.WarnOff) | FSharpDiagnosticSeverity.Hidden -> false let ReportDiagnosticAsWarning options (diagnostic, severity) = @@ -1931,13 +2156,13 @@ let ReportDiagnosticAsWarning options (diagnostic, severity) = | FSharpDiagnosticSeverity.Error -> false | FSharpDiagnosticSeverity.Warning -> let n = GetDiagnosticNumber diagnostic - IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn && - not (List.contains n options.WarnOff) + + IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn + && not (List.contains n options.WarnOff) // Informational become warning if explicitly on and not explicitly off | FSharpDiagnosticSeverity.Info -> let n = GetDiagnosticNumber diagnostic - List.contains n options.WarnOn && - not (List.contains n options.WarnOff) + List.contains n options.WarnOn && not (List.contains n options.WarnOff) | FSharpDiagnosticSeverity.Hidden -> false let ReportDiagnosticAsError options (diagnostic, severity) = @@ -1946,10 +2171,11 @@ let ReportDiagnosticAsError options (diagnostic, severity) = // Warnings become errors in some situations | FSharpDiagnosticSeverity.Warning -> let n = GetDiagnosticNumber diagnostic - IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn && - not (List.contains n options.WarnAsWarn) && - ((options.GlobalWarnAsError && not (List.contains n options.WarnOff)) || - List.contains n options.WarnAsError) + + IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn + && not (List.contains n options.WarnAsWarn) + && ((options.GlobalWarnAsError && not (List.contains n options.WarnOff)) + || List.contains n options.WarnAsError) // Informational become errors if explicitly WarnAsError | FSharpDiagnosticSeverity.Info -> let n = GetDiagnosticNumber diagnostic @@ -1959,7 +2185,6 @@ let ReportDiagnosticAsError options (diagnostic, severity) = //---------------------------------------------------------------------------- // Scoped #nowarn pragmas - /// Build an DiagnosticsLogger that delegates to another DiagnosticsLogger but filters warnings turned off by the given pragma declarations // // NOTE: we allow a flag to turn of strict file checking. This is because file names sometimes don't match due to use of @@ -1968,23 +2193,31 @@ let ReportDiagnosticAsError options (diagnostic, severity) = // However this is indicative of a more systematic problem where source-line // sensitive operations (lexfilter and warning filtering) do not always // interact well with #line directives. -type DiagnosticsLoggerFilteringByScopedPragmas (checkFile, scopedPragmas, diagnosticOptions:FSharpDiagnosticOptions, diagnosticsLogger: DiagnosticsLogger) = +type DiagnosticsLoggerFilteringByScopedPragmas + ( + checkFile, + scopedPragmas, + diagnosticOptions: FSharpDiagnosticOptions, + diagnosticsLogger: DiagnosticsLogger + ) = inherit DiagnosticsLogger("DiagnosticsLoggerFilteringByScopedPragmas") - override _.DiagnosticSink (diagnostic, severity) = + override _.DiagnosticSink(diagnostic, severity) = if severity = FSharpDiagnosticSeverity.Error then - diagnosticsLogger.DiagnosticSink (diagnostic, severity) + diagnosticsLogger.DiagnosticSink(diagnostic, severity) else let report = let warningNum = GetDiagnosticNumber diagnostic + match GetRangeOfDiagnostic diagnostic with | Some m -> scopedPragmas |> List.exists (fun pragma -> - let (ScopedPragma.WarningOff(pragmaRange, warningNumFromPragma)) = pragma - warningNum = warningNumFromPragma && - (not checkFile || m.FileIndex = pragmaRange.FileIndex) && - posGeq m.Start pragmaRange.Start) + let (ScopedPragma.WarningOff (pragmaRange, warningNumFromPragma)) = pragma + + warningNum = warningNumFromPragma + && (not checkFile || m.FileIndex = pragmaRange.FileIndex) + && posGeq m.Start pragmaRange.Start) |> not | None -> true @@ -1998,5 +2231,5 @@ type DiagnosticsLoggerFilteringByScopedPragmas (checkFile, scopedPragmas, diagno override _.ErrorCount = diagnosticsLogger.ErrorCount -let GetDiagnosticsLoggerFilteringByScopedPragmas(checkFile, scopedPragmas, diagnosticOptions, diagnosticsLogger) = +let GetDiagnosticsLoggerFilteringByScopedPragmas (checkFile, scopedPragmas, diagnosticOptions, diagnosticsLogger) = DiagnosticsLoggerFilteringByScopedPragmas(checkFile, scopedPragmas, diagnosticOptions, diagnosticsLogger) :> DiagnosticsLogger diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 21604212b79..227e23f5b32 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -45,48 +45,53 @@ open FSharp.Compiler.TypeProviders open FSharp.Core.CompilerServices #endif -let (++) x s = x @ [s] +let (++) x s = x @ [ s ] //---------------------------------------------------------------------------- // Signature and optimization data blobs //-------------------------------------------------------------------------- let IsSignatureDataResource (r: ILResource) = - r.Name.StartsWithOrdinal FSharpSignatureDataResourceName || - r.Name.StartsWithOrdinal FSharpSignatureDataResourceName2 + r.Name.StartsWithOrdinal FSharpSignatureDataResourceName + || r.Name.StartsWithOrdinal FSharpSignatureDataResourceName2 let IsOptimizationDataResource (r: ILResource) = - r.Name.StartsWithOrdinal FSharpOptimizationDataResourceName|| - r.Name.StartsWithOrdinal FSharpOptimizationDataResourceName2 + r.Name.StartsWithOrdinal FSharpOptimizationDataResourceName + || r.Name.StartsWithOrdinal FSharpOptimizationDataResourceName2 let GetSignatureDataResourceName (r: ILResource) = if r.Name.StartsWithOrdinal FSharpSignatureDataResourceName then String.dropPrefix r.Name FSharpSignatureDataResourceName elif r.Name.StartsWithOrdinal FSharpSignatureDataResourceName2 then String.dropPrefix r.Name FSharpSignatureDataResourceName2 - else failwith "GetSignatureDataResourceName" + else + failwith "GetSignatureDataResourceName" let GetOptimizationDataResourceName (r: ILResource) = if r.Name.StartsWithOrdinal FSharpOptimizationDataResourceName then String.dropPrefix r.Name FSharpOptimizationDataResourceName elif r.Name.StartsWithOrdinal FSharpOptimizationDataResourceName2 then String.dropPrefix r.Name FSharpOptimizationDataResourceName2 - else failwith "GetOptimizationDataResourceName" + else + failwith "GetOptimizationDataResourceName" let IsReflectedDefinitionsResource (r: ILResource) = r.Name.StartsWithOrdinal(QuotationPickler.SerializedReflectedDefinitionsResourceNameBase) let MakeILResource rName bytes = - { Name = rName - Location = ILResourceLocation.Local(ByteStorage.FromByteArray(bytes)) - Access = ILResourceAccess.Public - CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } + { + Name = rName + Location = ILResourceLocation.Local(ByteStorage.FromByteArray(bytes)) + Access = ILResourceAccess.Public + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } let PickleToResource inMem file (g: TcGlobals) scope rName p x = let file = PathMap.apply g.pathMap file let bytes = pickleObjWithDanglingCcus inMem file g scope p x + let byteStorage = if inMem then ByteStorage.FromMemoryAndCopy(bytes.AsMemory(), useBackingMemoryMappedFile = true) @@ -95,73 +100,109 @@ let PickleToResource inMem file (g: TcGlobals) scope rName p x = (bytes :> IDisposable).Dispose() - { Name = rName - Location = ILResourceLocation.Local(byteStorage) - Access = ILResourceAccess.Public - CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } + { + Name = rName + Location = ILResourceLocation.Local(byteStorage) + Access = ILResourceAccess.Public + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } let GetSignatureData (file, ilScopeRef, ilModule, byteReader) : PickledDataWithReferences = - unpickleObjWithDanglingCcus file ilScopeRef ilModule unpickleCcuInfo (byteReader()) + unpickleObjWithDanglingCcus file ilScopeRef ilModule unpickleCcuInfo (byteReader ()) let WriteSignatureData (tcConfig: TcConfig, tcGlobals, exportRemapping, ccu: CcuThunk, fileName, inMem) : ILResource = let mspec = ccu.Contents let mspec = ApplyExportRemappingToEntity tcGlobals exportRemapping mspec // For historical reasons, we use a different resource name for FSharp.Core, so older F# compilers // don't complain when they see the resource. - let rName = if ccu.AssemblyName = getFSharpCoreLibraryName then FSharpSignatureDataResourceName2 else FSharpSignatureDataResourceName + let rName = + if ccu.AssemblyName = getFSharpCoreLibraryName then + FSharpSignatureDataResourceName2 + else + FSharpSignatureDataResourceName let includeDir = - if String.IsNullOrEmpty tcConfig.implicitIncludeDir then "" + if String.IsNullOrEmpty tcConfig.implicitIncludeDir then + "" else tcConfig.implicitIncludeDir |> FileSystem.GetFullPathShim |> PathMap.applyDir tcGlobals.pathMap - PickleToResource inMem fileName tcGlobals ccu (rName+ccu.AssemblyName) pickleCcuInfo - { mspec=mspec - compileTimeWorkingDir=includeDir - usesQuotations = ccu.UsesFSharp20PlusQuotations } + PickleToResource + inMem + fileName + tcGlobals + ccu + (rName + ccu.AssemblyName) + pickleCcuInfo + { + mspec = mspec + compileTimeWorkingDir = includeDir + usesQuotations = ccu.UsesFSharp20PlusQuotations + } let GetOptimizationData (file, ilScopeRef, ilModule, byteReader) = - unpickleObjWithDanglingCcus file ilScopeRef ilModule Optimizer.u_CcuOptimizationInfo (byteReader()) + unpickleObjWithDanglingCcus file ilScopeRef ilModule Optimizer.u_CcuOptimizationInfo (byteReader ()) let WriteOptimizationData (tcGlobals, fileName, inMem, ccu: CcuThunk, modulInfo) = // For historical reasons, we use a different resource name for FSharp.Core, so older F# compilers // don't complain when they see the resource. - let rName = if ccu.AssemblyName = getFSharpCoreLibraryName then FSharpOptimizationDataResourceName2 else FSharpOptimizationDataResourceName - PickleToResource inMem fileName tcGlobals ccu (rName+ccu.AssemblyName) Optimizer.p_CcuOptimizationInfo modulInfo + let rName = + if ccu.AssemblyName = getFSharpCoreLibraryName then + FSharpOptimizationDataResourceName2 + else + FSharpOptimizationDataResourceName -let EncodeSignatureData(tcConfig: TcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, isIncrementalBuild) = + PickleToResource inMem fileName tcGlobals ccu (rName + ccu.AssemblyName) Optimizer.p_CcuOptimizationInfo modulInfo + +let EncodeSignatureData (tcConfig: TcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, isIncrementalBuild) = if tcConfig.GenerateSignatureData then - let resource = WriteSignatureData (tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, isIncrementalBuild) + let resource = + WriteSignatureData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, isIncrementalBuild) // The resource gets written to a file for FSharp.Core - let useDataFiles = (tcConfig.useOptimizationDataFile || tcGlobals.compilingFSharpCore) && not isIncrementalBuild + let useDataFiles = + (tcConfig.useOptimizationDataFile || tcGlobals.compilingFSharpCore) + && not isIncrementalBuild if useDataFiles then - let sigDataFileName = (FileSystemUtils.chopExtension outfile)+".sigdata" + let sigDataFileName = (FileSystemUtils.chopExtension outfile) + ".sigdata" let bytes = resource.GetBytes() - use fileStream = FileSystem.OpenFileForWriteShim(sigDataFileName, FileMode.Create, FileAccess.ReadWrite, FileShare.None) + + use fileStream = + FileSystem.OpenFileForWriteShim(sigDataFileName, FileMode.Create, FileAccess.ReadWrite, FileShare.None) bytes.CopyTo fileStream - let resources = - [ resource ] - let sigAttr = mkSignatureDataVersionAttr tcGlobals (parseILVersion FSharpBinaryMetadataFormatRevision) - [sigAttr], resources - else + + let resources = [ resource ] + + let sigAttr = + mkSignatureDataVersionAttr tcGlobals (parseILVersion FSharpBinaryMetadataFormatRevision) + + [ sigAttr ], resources + else [], [] -let EncodeOptimizationData(tcGlobals, tcConfig: TcConfig, outfile, exportRemapping, data, isIncrementalBuild) = +let EncodeOptimizationData (tcGlobals, tcConfig: TcConfig, outfile, exportRemapping, data, isIncrementalBuild) = if tcConfig.GenerateOptimizationData then let data = map2Of2 (Optimizer.RemapOptimizationInfo tcGlobals exportRemapping) data // As with the sigdata file, the optdata gets written to a file for FSharp.Core - let useDataFiles = (tcConfig.useOptimizationDataFile || tcGlobals.compilingFSharpCore) && not isIncrementalBuild + let useDataFiles = + (tcConfig.useOptimizationDataFile || tcGlobals.compilingFSharpCore) + && not isIncrementalBuild if useDataFiles then let ccu, modulInfo = data - let bytes = pickleObjWithDanglingCcus isIncrementalBuild outfile tcGlobals ccu Optimizer.p_CcuOptimizationInfo modulInfo - let optDataFileName = (FileSystemUtils.chopExtension outfile)+".optdata" - use fileStream = FileSystem.OpenFileForWriteShim(optDataFileName, FileMode.Create, FileAccess.ReadWrite, FileShare.None) + + let bytes = + pickleObjWithDanglingCcus isIncrementalBuild outfile tcGlobals ccu Optimizer.p_CcuOptimizationInfo modulInfo + + let optDataFileName = (FileSystemUtils.chopExtension outfile) + ".optdata" + + use fileStream = + FileSystem.OpenFileForWriteShim(optDataFileName, FileMode.Create, FileAccess.ReadWrite, FileShare.None) + fileStream.Write(bytes) let ccu, optData = @@ -169,9 +210,10 @@ let EncodeOptimizationData(tcGlobals, tcConfig: TcConfig, outfile, exportRemappi map2Of2 Optimizer.AbstractOptimizationInfoToEssentials data else data - [ WriteOptimizationData (tcGlobals, outfile, isIncrementalBuild, ccu, optData) ] + + [ WriteOptimizationData(tcGlobals, outfile, isIncrementalBuild, ccu, optData) ] else - [ ] + [] exception AssemblyNotResolved of originalName: string * range: range @@ -179,12 +221,14 @@ exception MSBuildReferenceResolutionWarning of message: string * warningCode: st exception MSBuildReferenceResolutionError of message: string * warningCode: string * range: range -let OpenILBinary(fileName, reduceMemoryUsage, pdbDirPath, shadowCopyReferences, tryGetMetadataSnapshot) = +let OpenILBinary (fileName, reduceMemoryUsage, pdbDirPath, shadowCopyReferences, tryGetMetadataSnapshot) = let opts: ILReaderOptions = - { metadataOnly = MetadataOnlyFlag.Yes - reduceMemoryUsage = reduceMemoryUsage - pdbDirPath = pdbDirPath - tryGetMetadataSnapshot = tryGetMetadataSnapshot } + { + metadataOnly = MetadataOnlyFlag.Yes + reduceMemoryUsage = reduceMemoryUsage + pdbDirPath = pdbDirPath + tryGetMetadataSnapshot = tryGetMetadataSnapshot + } let location = #if FX_NO_APP_DOMAINS @@ -193,16 +237,20 @@ let OpenILBinary(fileName, reduceMemoryUsage, pdbDirPath, shadowCopyReferences, if shadowCopyReferences then try System.Reflection.Assembly.ReflectionOnlyLoadFrom(fileName).Location - with _ -> fileName + with _ -> + fileName else #else - ignore shadowCopyReferences + ignore shadowCopyReferences #endif - fileName + fileName + AssemblyReader.GetILModuleReader(location, opts) [] -type ResolveAssemblyReferenceMode = Speculative | ReportErrors +type ResolveAssemblyReferenceMode = + | Speculative + | ReportErrors #if !NO_TYPEPROVIDERS type ResolvedExtensionReference = ResolvedExtensionReference of string * AssemblyReference list * Tainted list @@ -212,22 +260,25 @@ type ResolvedExtensionReference = ResolvedExtensionReference of string * Assembl [] #endif type AssemblyResolution = - { /// The original reference to the assembly. - originalReference: AssemblyReference + { + /// The original reference to the assembly. + originalReference: AssemblyReference + + /// Path to the resolvedFile + resolvedPath: string - /// Path to the resolvedFile - resolvedPath: string + /// Create the tooltip text for the assembly reference + prepareToolTip: unit -> string - /// Create the tooltip text for the assembly reference - prepareToolTip: unit -> string + /// Whether or not this is an installed system assembly (for example, System.dll) + sysdir: bool - /// Whether or not this is an installed system assembly (for example, System.dll) - sysdir: bool + /// Lazily populated ilAssemblyRef for this reference. + mutable ilAssemblyRef: ILAssemblyRef option + } - /// Lazily populated ilAssemblyRef for this reference. - mutable ilAssemblyRef: ILAssemblyRef option - } - override this.ToString() = sprintf "%s%s" (if this.sysdir then "[sys]" else "") this.resolvedPath + override this.ToString() = + sprintf "%s%s" (if this.sysdir then "[sys]" else "") this.resolvedPath member this.ProjectReference = this.originalReference.ProjectReference @@ -245,36 +296,44 @@ type AssemblyResolution = let assemblyRef = let readerSettings: ILReaderOptions = - { pdbDirPath=None - reduceMemoryUsage = reduceMemoryUsage - metadataOnly = MetadataOnlyFlag.Yes - tryGetMetadataSnapshot = tryGetMetadataSnapshot } + { + pdbDirPath = None + reduceMemoryUsage = reduceMemoryUsage + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = tryGetMetadataSnapshot + } + use reader = OpenILModuleReader this.resolvedPath readerSettings mkRefToILAssembly reader.ILModuleDef.ManifestOfAssembly + this.ilAssemblyRef <- Some assemblyRef assemblyRef type ImportedBinary = - { FileName: string - RawMetadata: IRawFSharpAssemblyData + { + FileName: string + RawMetadata: IRawFSharpAssemblyData #if !NO_TYPEPROVIDERS - ProviderGeneratedAssembly: System.Reflection.Assembly option - IsProviderGenerated: bool - ProviderGeneratedStaticLinkMap: ProvidedAssemblyStaticLinkingMap option + ProviderGeneratedAssembly: System.Reflection.Assembly option + IsProviderGenerated: bool + ProviderGeneratedStaticLinkMap: ProvidedAssemblyStaticLinkingMap option #endif - ILAssemblyRefs: ILAssemblyRef list - ILScopeRef: ILScopeRef } + ILAssemblyRefs: ILAssemblyRef list + ILScopeRef: ILScopeRef + } type ImportedAssembly = - { ILScopeRef: ILScopeRef - FSharpViewOfMetadata: CcuThunk - AssemblyAutoOpenAttributes: string list - AssemblyInternalsVisibleToAttributes: string list + { + ILScopeRef: ILScopeRef + FSharpViewOfMetadata: CcuThunk + AssemblyAutoOpenAttributes: string list + AssemblyInternalsVisibleToAttributes: string list #if !NO_TYPEPROVIDERS - IsProviderGenerated: bool - mutable TypeProviders: Tainted list + IsProviderGenerated: bool + mutable TypeProviders: Tainted list #endif - FSharpOptimizationData: Microsoft.FSharp.Control.Lazy> } + FSharpOptimizationData: Microsoft.FSharp.Control.Lazy> + } type AvailableImportedAssembly = | ResolvedImportedAssembly of ImportedAssembly @@ -285,87 +344,102 @@ type CcuLoadFailureAction = | ReturnNone type TcImportsLockToken() = - interface LockToken + interface LockToken -type TcImportsLock = Lock +type TcImportsLock = Lock let RequireTcImportsLock (_tcitok: TcImportsLockToken, _thingProtected: 'T) = () +// if this is a #r reference (not from dummy range), make sure the directory of the declaring +// file is included in the search path. This should ideally already be one of the search paths, but +// during some global checks it won't be. We append to the end of the search list so that this is the last +// place that is checked. +let isHashRReference (r: range) = + not (equals r range0) + && not (equals r rangeStartup) + && not (equals r rangeCmdArgs) + && FileSystem.IsPathRootedShim r.FileName + +let IsNetModule fileName = + let ext = Path.GetExtension fileName + String.Compare(ext, ".netmodule", StringComparison.OrdinalIgnoreCase) = 0 + +let IsDLL fileName = + let ext = Path.GetExtension fileName + String.Compare(ext, ".dll", StringComparison.OrdinalIgnoreCase) = 0 + +let IsExe fileName = + let ext = Path.GetExtension fileName + String.Compare(ext, ".exe", StringComparison.OrdinalIgnoreCase) = 0 + type TcConfig with - member tcConfig.TryResolveLibWithDirectories (r: AssemblyReference) = + member tcConfig.TryResolveLibWithDirectories(r: AssemblyReference) = let m, nm = r.Range, r.Text use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter - // Only want to resolve certain extensions (otherwise, 'System.Xml' is ambiguous). - // MSBuild resolution is limited to .exe and .dll so do the same here. - let ext = Path.GetExtension nm - let isNetModule = String.Compare(ext, ".netmodule", StringComparison.OrdinalIgnoreCase)=0 // See if the language service has already produced the contents of the assembly for us, virtually match r.ProjectReference with | Some _ -> let resolved = r.Text let sysdir = tcConfig.IsSystemAssembly resolved + Some - { originalReference = r - resolvedPath = resolved - prepareToolTip = (fun () -> resolved) - sysdir = sysdir - ilAssemblyRef = None } + { + originalReference = r + resolvedPath = resolved + prepareToolTip = (fun () -> resolved) + sysdir = sysdir + ilAssemblyRef = None + } | None -> - if String.Compare(ext, ".dll", StringComparison.OrdinalIgnoreCase)=0 - || String.Compare(ext, ".exe", StringComparison.OrdinalIgnoreCase)=0 - || isNetModule then - - let searchPaths = - seq { - yield! tcConfig.GetSearchPathsForLibraryFiles() - - // if this is a #r reference (not from dummy range), make sure the directory of the declaring - // file is included in the search path. This should ideally already be one of the search paths, but - // during some global checks it won't be. We append to the end of the search list so that this is the last - // place that is checked. - let isPoundRReference (r: range) = - not (equals r range0) && - not (equals r rangeStartup) && - not (equals r rangeCmdArgs) && - FileSystem.IsPathRootedShim r.FileName - - if isPoundRReference m then - yield Path.GetDirectoryName(m.FileName) - } + // Only want to resolve certain extensions (otherwise, 'System.Xml' is ambiguous). + // MSBuild resolution is limited to .exe and .dll so do the same here. + if IsDLL nm || IsExe nm || IsNetModule nm then - let resolved = TryResolveFileUsingPaths(searchPaths, m, nm) - match resolved with - | Some resolved -> - let sysdir = tcConfig.IsSystemAssembly resolved - Some - { originalReference = r - resolvedPath = resolved - prepareToolTip = (fun () -> - let fusionName = System.Reflection.AssemblyName.GetAssemblyName(resolved).ToString() - let line(append: string) = append.Trim([|' '|])+"\n" - line resolved + line fusionName) - sysdir = sysdir - ilAssemblyRef = None } - | None -> None - else None + let searchPaths = + seq { + yield! tcConfig.GetSearchPathsForLibraryFiles() + + if isHashRReference m then Path.GetDirectoryName(m.FileName) + } - member tcConfig.ResolveLibWithDirectories (ccuLoadFailureAction, r: AssemblyReference) = + let resolved = TryResolveFileUsingPaths(searchPaths, m, nm) + + match resolved with + | Some resolved -> + let sysdir = tcConfig.IsSystemAssembly resolved + + Some + { + originalReference = r + resolvedPath = resolved + prepareToolTip = + (fun () -> + let fusionName = System.Reflection.AssemblyName.GetAssemblyName(resolved).ToString() + let line (append: string) = append.Trim(' ') + "\n" + line resolved + line fusionName) + sysdir = sysdir + ilAssemblyRef = None + } + | None -> None + else + None + + member tcConfig.ResolveLibWithDirectories(ccuLoadFailureAction, r: AssemblyReference) = let m, nm = r.Range, r.Text use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter - // test for both libraries and executables - let ext = Path.GetExtension nm - let isExe = (String.Compare(ext, ".exe", StringComparison.OrdinalIgnoreCase) = 0) - let isDLL = (String.Compare(ext, ".dll", StringComparison.OrdinalIgnoreCase) = 0) - let isNetModule = (String.Compare(ext, ".netmodule", StringComparison.OrdinalIgnoreCase) = 0) let rs = - if isExe || isDLL || isNetModule then - [r] + if IsExe nm || IsDLL nm || IsNetModule nm then + [ r ] else - [AssemblyReference(m, nm+".dll", None);AssemblyReference(m, nm+".exe", None);AssemblyReference(m, nm+".netmodule", None)] + [ + AssemblyReference(m, nm + ".dll", None) + AssemblyReference(m, nm + ".exe", None) + AssemblyReference(m, nm + ".netmodule", None) + ] match rs |> List.tryPick (fun r -> tcConfig.TryResolveLibWithDirectories(r)) with | Some res -> Some res @@ -376,29 +450,30 @@ type TcConfig with raise (FileNameNotResolved(nm, searchMessage, m)) | CcuLoadFailureAction.ReturnNone -> None - member tcConfig.MsBuildResolve (references, mode, errorAndWarningRange, showMessages) = + member tcConfig.MsBuildResolve(references, mode, errorAndWarningRange, showMessages) = let logMessage showMessages = - if showMessages && tcConfig.showReferenceResolutions then (fun (message: string)->dprintf "%s\n" message) - else ignore + if showMessages && tcConfig.showReferenceResolutions then + (fun (message: string) -> printfn "%s" message) + else + ignore let logDiagnostic showMessages = - (fun isError code message-> + (fun isError code message -> if showMessages && mode = ResolveAssemblyReferenceMode.ReportErrors then - if isError then - errorR(MSBuildReferenceResolutionError(code, message, errorAndWarningRange)) - else - match code with - // These are warnings that mean 'not resolved' for some assembly. - // Note that we don't get to know the name of the assembly that couldn't be resolved. - // Ignore these and rely on the logic below to emit an error for each unresolved reference. - | "MSB3246" // Resolved file has a bad image, no metadata, or is otherwise inaccessible. - | "MSB3106" - -> () - | _ -> - if code = "MSB3245" then - errorR(MSBuildReferenceResolutionWarning(code, message, errorAndWarningRange)) - else - warning(MSBuildReferenceResolutionWarning(code, message, errorAndWarningRange))) + if isError then + errorR (MSBuildReferenceResolutionError(code, message, errorAndWarningRange)) + else + match code with + // These are warnings that mean 'not resolved' for some assembly. + // Note that we don't get to know the name of the assembly that couldn't be resolved. + // Ignore these and rely on the logic below to emit an error for each unresolved reference. + | "MSB3246" // Resolved file has a bad image, no metadata, or is otherwise inaccessible. + | "MSB3106" -> () + | _ -> + if code = "MSB3245" then + errorR (MSBuildReferenceResolutionWarning(code, message, errorAndWarningRange)) + else + warning (MSBuildReferenceResolutionWarning(code, message, errorAndWarningRange))) let targetProcessorArchitecture = match tcConfig.platform with @@ -410,8 +485,8 @@ type TcConfig with | Some IA64 -> "ia64" try - tcConfig.legacyReferenceResolver.Impl.Resolve - (tcConfig.resolutionEnvironment, + tcConfig.legacyReferenceResolver.Impl.Resolve( + tcConfig.resolutionEnvironment, references, tcConfig.targetFrameworkVersion, tcConfig.GetTargetFrameworkDirectories(), @@ -419,226 +494,322 @@ type TcConfig with tcConfig.fsharpBinariesDir, // FSharp binaries directory tcConfig.includes, // Explicit include directories tcConfig.implicitIncludeDir, // Implicit include directory (likely the project directory) - logMessage showMessages, logDiagnostic showMessages) - with - | LegacyResolutionFailure -> error(Error(FSComp.SR.buildAssemblyResolutionFailed(), errorAndWarningRange)) - + logMessage showMessages, + logDiagnostic showMessages + ) + with LegacyResolutionFailure -> + error (Error(FSComp.SR.buildAssemblyResolutionFailed (), errorAndWarningRange)) // NOTE!! if mode=Speculative then this method must not report ANY warnings or errors through 'warning' or 'error'. Instead // it must return warnings and errors as data // // NOTE!! if mode=ReportErrors then this method must not raise exceptions. It must just report the errors and recover - static member TryResolveLibsUsingMSBuildRules (tcConfig: TcConfig, + static member TryResolveLibsUsingMSBuildRules + ( + tcConfig: TcConfig, originalReferences: AssemblyReference list, errorAndWarningRange: range, - mode: ResolveAssemblyReferenceMode) : AssemblyResolution list * UnresolvedAssemblyReference list = + mode: ResolveAssemblyReferenceMode + ) : AssemblyResolution list * UnresolvedAssemblyReference list = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter + if tcConfig.useSimpleResolution then failwith "MSBuild resolution is not supported." - if originalReferences=[] then [], [] + + if originalReferences = [] then + [], [] else // Group references by name with range values in the grouped value list. // In the grouped reference, store the index of the last use of the reference. let groupedReferences = originalReferences |> List.indexed - |> Seq.groupBy(fun (_, reference) -> reference.Text) - |> Seq.map(fun (assemblyName, assemblyAndIndexGroup)-> + |> List.groupBy (fun (_, reference) -> reference.Text) + |> List.map (fun (assemblyName, assemblyAndIndexGroup) -> let assemblyAndIndexGroup = assemblyAndIndexGroup |> List.ofSeq let highestPosition = assemblyAndIndexGroup |> List.maxBy fst |> fst let assemblyGroup = assemblyAndIndexGroup |> List.map snd assemblyName, highestPosition, assemblyGroup) - |> Array.ofSeq + |> Array.ofList // First, try to resolve everything as a file using simple resolution let resolvedAsFile = - groupedReferences - |> Array.map(fun (_filename, maxIndexOfReference, references)-> - let assemblyResolution = references |> List.choose (fun r -> tcConfig.TryResolveLibWithDirectories r) - (maxIndexOfReference, assemblyResolution)) - |> Array.filter(fun (_, refs)->refs |> isNil |> not) + [| + for (_filename, maxIndexOfReference, references) in groupedReferences do + let assemblyResolution = + references |> List.choose (fun r -> tcConfig.TryResolveLibWithDirectories r) + + if not assemblyResolution.IsEmpty then + (maxIndexOfReference, assemblyResolution) + |] + + let toMsBuild = + [| + for i in 0 .. groupedReferences.Length - 1 do + let ref, i0, _ = groupedReferences[i] - let toMsBuild = [|0..groupedReferences.Length-1|] - |> Array.map(fun i->(p13 groupedReferences[i]), (p23 groupedReferences[i]), i) - |> Array.filter (fun (_, i0, _)->resolvedAsFile|>Array.exists(fun (i1, _) -> i0=i1)|>not) - |> Array.map(fun (ref, _, i)->ref, string i) + if resolvedAsFile |> Array.exists (fun (i1, _) -> i0 = i1) |> not then + ref, string i + |] - let resolutions = tcConfig.MsBuildResolve(toMsBuild, mode, errorAndWarningRange, (*showMessages*)true) + let resolutions = + tcConfig.MsBuildResolve(toMsBuild, mode, errorAndWarningRange, true) // Map back to original assembly resolutions. let resolvedByMsbuild = - resolutions - |> Array.map(fun resolvedFile -> - let i = int resolvedFile.baggage - let _, maxIndexOfReference, ms = groupedReferences[i] - let assemblyResolutions = - ms|>List.map(fun originalReference -> - Debug.Assert(FileSystem.IsPathRootedShim(resolvedFile.itemSpec), sprintf "msbuild-resolved path is not absolute: '%s'" resolvedFile.itemSpec) - let canonicalItemSpec = FileSystem.GetFullPathShim(resolvedFile.itemSpec) - { originalReference=originalReference - resolvedPath=canonicalItemSpec - prepareToolTip = (fun () -> resolvedFile.prepareToolTip (originalReference.Text, canonicalItemSpec)) - sysdir= tcConfig.IsSystemAssembly canonicalItemSpec - ilAssemblyRef = None }) - (maxIndexOfReference, assemblyResolutions)) + [| + for resolvedFile in resolutions do + let i = int resolvedFile.baggage + let _, maxIndexOfReference, ms = groupedReferences[i] + + let assemblyResolutions = + [ + for originalReference in ms do + let canonicalItemSpec = FileSystem.GetFullPathShim(resolvedFile.itemSpec) + + { + originalReference = originalReference + resolvedPath = canonicalItemSpec + prepareToolTip = (fun () -> resolvedFile.prepareToolTip (originalReference.Text, canonicalItemSpec)) + sysdir = tcConfig.IsSystemAssembly canonicalItemSpec + ilAssemblyRef = None + } + ] + + (maxIndexOfReference, assemblyResolutions) + |] // When calculating the resulting resolutions, we're going to use the index of the reference // in the original specification and resort it to match the ordering that we had. let resultingResolutions = - [resolvedByMsbuild;resolvedAsFile] - |> Array.concat - |> Array.sortBy fst - |> Array.map snd - |> List.ofArray - |> List.concat + [ resolvedByMsbuild; resolvedAsFile ] + |> Array.concat + |> Array.sortBy fst + |> Array.map snd + |> List.ofArray + |> List.concat // O(N^2) here over a small set of referenced assemblies. - let IsResolved(originalName: string) = - if resultingResolutions |> List.exists(fun resolution -> resolution.originalReference.Text = originalName) then true + let IsResolved (originalName: string) = + if resultingResolutions + |> List.exists (fun resolution -> resolution.originalReference.Text = originalName) then + true else // MSBuild resolution may have unified the result of two duplicate references. Try to re-resolve now. // If re-resolution worked then this was a removed duplicate. - tcConfig.MsBuildResolve([|originalName, ""|], mode, errorAndWarningRange, (*showMessages*)false).Length<>0 + let references = [| (originalName, "") |] + + let resolutions = + tcConfig.MsBuildResolve(references, mode, errorAndWarningRange, false) + + resolutions.Length <> 0 let unresolvedReferences = - groupedReferences - //|> Array.filter(p13 >> IsNotFileOrIsAssembly) - |> Array.filter(p13 >> IsResolved >> not) - |> List.ofArray + groupedReferences |> Array.filter (p13 >> IsResolved >> not) |> List.ofArray + + let unresolved = + [ + for (name, _, r) in unresolvedReferences -> UnresolvedAssemblyReference(name, r) + ] // If mode=Speculative, then we haven't reported any errors. // We report the error condition by returning an empty list of resolutions - if mode = ResolveAssemblyReferenceMode.Speculative && (List.length unresolvedReferences) > 0 then - [], (List.ofArray groupedReferences) |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference + if mode = ResolveAssemblyReferenceMode.Speculative + && unresolvedReferences.Length > 0 then + [], unresolved else - resultingResolutions, unresolvedReferences |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference + resultingResolutions, unresolved [] type TcAssemblyResolutions(tcConfig: TcConfig, results: AssemblyResolution list, unresolved: UnresolvedAssemblyReference list) = - let originalReferenceToResolution = results |> List.map (fun r -> r.originalReference.Text, r) |> Map.ofList - let resolvedPathToResolution = results |> List.map (fun r -> r.resolvedPath, r) |> Map.ofList + let originalReferenceToResolution = + results |> List.map (fun r -> r.originalReference.Text, r) |> Map.ofList + + let resolvedPathToResolution = + results |> List.map (fun r -> r.resolvedPath, r) |> Map.ofList /// Add some resolutions to the map of resolution results. - member _.AddResolutionResults newResults = TcAssemblyResolutions(tcConfig, results @ newResults, unresolved) + member _.AddResolutionResults newResults = + TcAssemblyResolutions(tcConfig, results @ newResults, unresolved) /// Add some unresolved results. - member _.AddUnresolvedReferences newUnresolved = TcAssemblyResolutions(tcConfig, results, unresolved @ newUnresolved) + member _.AddUnresolvedReferences newUnresolved = + TcAssemblyResolutions(tcConfig, results, unresolved @ newUnresolved) /// Get information about referenced DLLs member _.GetAssemblyResolutions() = results member _.GetUnresolvedReferences() = unresolved - member _.TryFindByOriginalReference(assemblyReference: AssemblyReference) = originalReferenceToResolution.TryFind assemblyReference.Text + member _.TryFindByOriginalReference(assemblyReference: AssemblyReference) = + originalReferenceToResolution.TryFind assemblyReference.Text /// Only used by F# Interactive member _.TryFindByExactILAssemblyRef assemblyRef = - results |> List.tryFind (fun ar-> - let r = ar.GetILAssemblyRef(tcConfig.reduceMemoryUsage, tcConfig.tryGetMetadataSnapshot) + results + |> List.tryFind (fun ar -> + let r = + ar.GetILAssemblyRef(tcConfig.reduceMemoryUsage, tcConfig.tryGetMetadataSnapshot) + r = assemblyRef) /// Only used by F# Interactive member _.TryFindBySimpleAssemblyName simpleAssemName = - results |> List.tryFind (fun ar-> - let r = ar.GetILAssemblyRef(tcConfig.reduceMemoryUsage, tcConfig.tryGetMetadataSnapshot) + results + |> List.tryFind (fun ar -> + let r = + ar.GetILAssemblyRef(tcConfig.reduceMemoryUsage, tcConfig.tryGetMetadataSnapshot) + r.Name = simpleAssemName) member _.TryFindByResolvedPath nm = resolvedPathToResolution.TryFind nm - member _.TryFindByOriginalReferenceText nm = originalReferenceToResolution.TryFind nm + member _.TryFindByOriginalReferenceText nm = + originalReferenceToResolution.TryFind nm - static member ResolveAssemblyReferences (tcConfig: TcConfig, assemblyList: AssemblyReference list, knownUnresolved: UnresolvedAssemblyReference list) : TcAssemblyResolutions = + static member ResolveAssemblyReferences + ( + tcConfig: TcConfig, + assemblyList: AssemblyReference list, + knownUnresolved: UnresolvedAssemblyReference list + ) : TcAssemblyResolutions = let resolved, unresolved = if tcConfig.useSimpleResolution then let resolutions = assemblyList |> List.map (fun assemblyReference -> - try - Choice1Of2 (tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.RaiseError, assemblyReference) |> Option.get) - with e -> - errorRecovery e assemblyReference.Range - Choice2Of2 assemblyReference) - let successes = resolutions |> List.choose (function Choice1Of2 x -> Some x | _ -> None) - let failures = resolutions |> List.choose (function Choice2Of2 x -> Some (UnresolvedAssemblyReference(x.Text, [x])) | _ -> None) + try + let resolutionOpt = + tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.RaiseError, assemblyReference) + + Choice1Of2 resolutionOpt.Value + with e -> + errorRecovery e assemblyReference.Range + Choice2Of2 assemblyReference) + + let successes = + resolutions + |> List.choose (function + | Choice1Of2 x -> Some x + | _ -> None) + + let failures = + resolutions + |> List.choose (function + | Choice2Of2 x -> Some(UnresolvedAssemblyReference(x.Text, [ x ])) + | _ -> None) + successes, failures else // we don't want to do assembly resolution concurrently, we assume MSBuild doesn't handle this - TcConfig.TryResolveLibsUsingMSBuildRules (tcConfig, assemblyList, rangeStartup, ResolveAssemblyReferenceMode.ReportErrors) + TcConfig.TryResolveLibsUsingMSBuildRules(tcConfig, assemblyList, rangeStartup, ResolveAssemblyReferenceMode.ReportErrors) + TcAssemblyResolutions(tcConfig, resolved, unresolved @ knownUnresolved) - static member GetAllDllReferences (tcConfig: TcConfig) = [ + static member GetAllDllReferences(tcConfig: TcConfig) = + [ let primaryReference = tcConfig.PrimaryAssemblyDllReference() let assumeDotNetFramework = primaryReference.SimpleAssemblyNameIs("mscorlib") if not tcConfig.compilingFSharpCore then - yield tcConfig.CoreLibraryDllReference() + tcConfig.CoreLibraryDllReference() + if assumeDotNetFramework then // When building desktop then we need these additional dependencies - yield AssemblyReference(rangeStartup, "System.Numerics.dll", None) - yield AssemblyReference(rangeStartup, "System.dll", None) + AssemblyReference(rangeStartup, "System.Numerics.dll", None) + AssemblyReference(rangeStartup, "System.dll", None) let asm = AssemblyReference(rangeStartup, "netstandard.dll", None) + let found = if tcConfig.useSimpleResolution then - match tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.ReturnNone, asm) with + match tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.ReturnNone, asm) with | Some _ -> true | None -> false else - let resolutions = tcConfig.MsBuildResolve([|asm.Text, ""|], ResolveAssemblyReferenceMode.Speculative, rangeStartup, (*showMessages*)false) + let references = [| (asm.Text, "") |] + + let resolutions = + tcConfig.MsBuildResolve(references, ResolveAssemblyReferenceMode.Speculative, rangeStartup, false) + resolutions.Length = 1 - if found then yield asm + + if found then asm if tcConfig.implicitlyReferenceDotNetAssemblies then - let references, _useDotNetFramework = tcConfig.FxResolver.GetDefaultReferences(tcConfig.useFsiAuxLib) + let references, _useDotNetFramework = + tcConfig.FxResolver.GetDefaultReferences(tcConfig.useFsiAuxLib) + for s in references do - yield AssemblyReference(rangeStartup, (if s.EndsWith(".dll", StringComparison.OrdinalIgnoreCase) then s else s+".dll"), None) + let referenceText = + if s.EndsWith(".dll", StringComparison.OrdinalIgnoreCase) then + s + else + s + ".dll" + + AssemblyReference(rangeStartup, referenceText, None) yield! tcConfig.referencedDLLs ] - static member SplitNonFoundationalResolutions (tcConfig: TcConfig) = + static member SplitNonFoundationalResolutions(tcConfig: TcConfig) = let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig - let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (tcConfig, assemblyList, tcConfig.knownUnresolvedReferences) - let frameworkDLLs, nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) + + let resolutions = + TcAssemblyResolutions.ResolveAssemblyReferences(tcConfig, assemblyList, tcConfig.knownUnresolvedReferences) + + let frameworkDLLs, nonFrameworkReferences = + resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) + let unresolved = resolutions.GetUnresolvedReferences() #if DEBUG let mutable itFailed = false - let addedText = "\nIf you want to debug this right now, attach a debugger, and put a breakpoint in 'CompileOps.fs' near the text '!itFailed', and you can re-step through the assembly resolution logic." - for UnresolvedAssemblyReference(referenceText, _ranges) in unresolved do + let addedText = + "\nIf you want to debug this right now, attach a debugger, and put a breakpoint in 'CompileOps.fs' near the text '!itFailed', and you can re-step through the assembly resolution logic." + + for UnresolvedAssemblyReference (referenceText, _ranges) in unresolved do if referenceText.Contains("mscorlib") then Debug.Assert(false, sprintf "whoops, did not resolve mscorlib: '%s'%s" referenceText addedText) itFailed <- true for x in frameworkDLLs do - if not(FileSystem.IsPathRootedShim(x.resolvedPath)) then + if not (FileSystem.IsPathRootedShim(x.resolvedPath)) then Debug.Assert(false, sprintf "frameworkDLL should be absolute path: '%s'%s" x.resolvedPath addedText) itFailed <- true for x in nonFrameworkReferences do - if not(FileSystem.IsPathRootedShim(x.resolvedPath)) then + if not (FileSystem.IsPathRootedShim(x.resolvedPath)) then Debug.Assert(false, sprintf "nonFrameworkReference should be absolute path: '%s'%s" x.resolvedPath addedText) itFailed <- true if itFailed then // idea is, put a breakpoint here and then step through let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig - let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (tcConfig, assemblyList, []) - let _frameworkDLLs, _nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) + + let resolutions = + TcAssemblyResolutions.ResolveAssemblyReferences(tcConfig, assemblyList, []) + + let _frameworkDLLs, _nonFrameworkReferences = + resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) + () #endif frameworkDLLs, nonFrameworkReferences, unresolved - static member BuildFromPriorResolutions (tcConfig: TcConfig, resolutions, knownUnresolved) = + static member BuildFromPriorResolutions(tcConfig: TcConfig, resolutions, knownUnresolved) = let references = resolutions |> List.map (fun r -> r.originalReference) - TcAssemblyResolutions.ResolveAssemblyReferences (tcConfig, references, knownUnresolved) + TcAssemblyResolutions.ResolveAssemblyReferences(tcConfig, references, knownUnresolved) static member GetAssemblyResolutionInformation(tcConfig: TcConfig) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig - let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (tcConfig, assemblyList, []) + + let resolutions = + TcAssemblyResolutions.ResolveAssemblyReferences(tcConfig, assemblyList, []) + resolutions.GetAssemblyResolutions(), resolutions.GetUnresolvedReferences() //---------------------------------------------------------------------------- @@ -651,159 +822,208 @@ let GetNameOfILModule (m: ILModuleDef) = let MakeScopeRefForILModule (ilModule: ILModuleDef) = match ilModule.Manifest with - | Some m -> ILScopeRef.Assembly (mkRefToILAssembly m) - | None -> ILScopeRef.Module (mkRefToILModule ilModule) + | Some m -> ILScopeRef.Assembly(mkRefToILAssembly m) + | None -> ILScopeRef.Module(mkRefToILModule ilModule) let GetCustomAttributesOfILModule (ilModule: ILModuleDef) = - (match ilModule.Manifest with Some m -> m.CustomAttrs | None -> ilModule.CustomAttrs).AsList() + let attrs = + match ilModule.Manifest with + | Some m -> m.CustomAttrs + | None -> ilModule.CustomAttrs + + attrs.AsList() let GetAutoOpenAttributes ilModule = ilModule |> GetCustomAttributesOfILModule |> List.choose TryFindAutoOpenAttr let GetInternalsVisibleToAttributes ilModule = - ilModule |> GetCustomAttributesOfILModule |> List.choose TryFindInternalsVisibleToAttr + ilModule + |> GetCustomAttributesOfILModule + |> List.choose TryFindInternalsVisibleToAttr + +type RawFSharpAssemblyDataBackedByFileOnDisk(ilModule: ILModuleDef, ilAssemblyRefs) = + let externalSigAndOptData = [ "FSharp.Core" ] -type RawFSharpAssemblyDataBackedByFileOnDisk (ilModule: ILModuleDef, ilAssemblyRefs) = - let externalSigAndOptData = ["FSharp.Core"] interface IRawFSharpAssemblyData with - member _.GetAutoOpenAttributes() = GetAutoOpenAttributes ilModule + member _.GetAutoOpenAttributes() = GetAutoOpenAttributes ilModule - member _.GetInternalsVisibleToAttributes() = GetInternalsVisibleToAttributes ilModule + member _.GetInternalsVisibleToAttributes() = + GetInternalsVisibleToAttributes ilModule - member _.TryGetILModuleDef() = Some ilModule + member _.TryGetILModuleDef() = Some ilModule - member _.GetRawFSharpSignatureData(m, ilShortAssemName, fileName) = + member _.GetRawFSharpSignatureData(m, ilShortAssemName, fileName) = let resources = ilModule.Resources.AsList() + let sigDataReaders = - [ for iresource in resources do - if IsSignatureDataResource iresource then - let ccuName = GetSignatureDataResourceName iresource - yield (ccuName, fun () -> iresource.GetBytes()) ] + [ + for iresource in resources do + if IsSignatureDataResource iresource then + let ccuName = GetSignatureDataResourceName iresource + (ccuName, (fun () -> iresource.GetBytes())) + ] let sigDataReaders = if sigDataReaders.IsEmpty && List.contains ilShortAssemName externalSigAndOptData then let sigFileName = Path.ChangeExtension(fileName, "sigdata") + if not (FileSystem.FileExistsShim sigFileName) then - error(Error(FSComp.SR.buildExpectedSigdataFile (FileSystem.GetFullPathShim sigFileName), m)) - [ (ilShortAssemName, fun () -> FileSystem.OpenFileForReadShim(sigFileName, useMemoryMappedFile=true, shouldShadowCopy=true).AsByteMemory().AsReadOnly())] + error (Error(FSComp.SR.buildExpectedSigdataFile (FileSystem.GetFullPathShim sigFileName), m)) + + [ + (ilShortAssemName, + fun () -> + FileSystem + .OpenFileForReadShim(sigFileName, useMemoryMappedFile = true, shouldShadowCopy = true) + .AsByteMemory() + .AsReadOnly()) + ] else sigDataReaders + sigDataReaders - member _.GetRawFSharpOptimizationData(m, ilShortAssemName, fileName) = + member _.GetRawFSharpOptimizationData(m, ilShortAssemName, fileName) = let optDataReaders = ilModule.Resources.AsList() - |> List.choose (fun r -> if IsOptimizationDataResource r then Some(GetOptimizationDataResourceName r, (fun () -> r.GetBytes())) else None) + |> List.choose (fun r -> + if IsOptimizationDataResource r then + Some(GetOptimizationDataResourceName r, (fun () -> r.GetBytes())) + else + None) // Look for optimization data in a file let optDataReaders = if optDataReaders.IsEmpty && List.contains ilShortAssemName externalSigAndOptData then let optDataFile = Path.ChangeExtension(fileName, "optdata") + if not (FileSystem.FileExistsShim optDataFile) then - error(Error(FSComp.SR.buildExpectedFileAlongSideFSharpCore(optDataFile, FileSystem.GetFullPathShim optDataFile), m)) - [ (ilShortAssemName, (fun () -> FileSystem.OpenFileForReadShim(optDataFile, useMemoryMappedFile=true, shouldShadowCopy=true).AsByteMemory().AsReadOnly()))] + let fullPath = FileSystem.GetFullPathShim optDataFile + error (Error(FSComp.SR.buildExpectedFileAlongSideFSharpCore (optDataFile, fullPath), m)) + + [ + (ilShortAssemName, + (fun () -> + FileSystem + .OpenFileForReadShim(optDataFile, useMemoryMappedFile = true, shouldShadowCopy = true) + .AsByteMemory() + .AsReadOnly())) + ] else optDataReaders + optDataReaders - member _.GetRawTypeForwarders() = + member _.GetRawTypeForwarders() = match ilModule.Manifest with | Some manifest -> manifest.ExportedTypes | None -> mkILExportedTypes [] - member _.ShortAssemblyName = GetNameOfILModule ilModule + member _.ShortAssemblyName = GetNameOfILModule ilModule - member _.ILScopeRef = MakeScopeRefForILModule ilModule + member _.ILScopeRef = MakeScopeRefForILModule ilModule - member _.ILAssemblyRefs = ilAssemblyRefs + member _.ILAssemblyRefs = ilAssemblyRefs - member _.HasAnyFSharpSignatureDataAttribute = + member _.HasAnyFSharpSignatureDataAttribute = let attrs = GetCustomAttributesOfILModule ilModule List.exists IsSignatureDataVersionAttr attrs - member _.HasMatchingFSharpSignatureDataAttribute = + member _.HasMatchingFSharpSignatureDataAttribute = let attrs = GetCustomAttributesOfILModule ilModule - List.exists (IsMatchingSignatureDataVersionAttr (parseILVersion FSharpBinaryMetadataFormatRevision)) attrs + List.exists (IsMatchingSignatureDataVersionAttr(parseILVersion FSharpBinaryMetadataFormatRevision)) attrs [] -type RawFSharpAssemblyData (ilModule: ILModuleDef, ilAssemblyRefs) = +type RawFSharpAssemblyData(ilModule: ILModuleDef, ilAssemblyRefs) = interface IRawFSharpAssemblyData with - member _.GetAutoOpenAttributes() = GetAutoOpenAttributes ilModule + member _.GetAutoOpenAttributes() = GetAutoOpenAttributes ilModule - member _.GetInternalsVisibleToAttributes() = GetInternalsVisibleToAttributes ilModule + member _.GetInternalsVisibleToAttributes() = + GetInternalsVisibleToAttributes ilModule - member _.TryGetILModuleDef() = Some ilModule + member _.TryGetILModuleDef() = Some ilModule - member _.GetRawFSharpSignatureData(_, _, _) = + member _.GetRawFSharpSignatureData(_, _, _) = let resources = ilModule.Resources.AsList() - [ for iresource in resources do - if IsSignatureDataResource iresource then - let ccuName = GetSignatureDataResourceName iresource - yield (ccuName, fun () -> iresource.GetBytes()) ] - member _.GetRawFSharpOptimizationData(_, _, _) = + [ + for iresource in resources do + if IsSignatureDataResource iresource then + let ccuName = GetSignatureDataResourceName iresource + (ccuName, (fun () -> iresource.GetBytes())) + ] + + member _.GetRawFSharpOptimizationData(_, _, _) = ilModule.Resources.AsList() - |> List.choose (fun r -> if IsOptimizationDataResource r then Some(GetOptimizationDataResourceName r, (fun () -> r.GetBytes())) else None) + |> List.choose (fun r -> + if IsOptimizationDataResource r then + Some(GetOptimizationDataResourceName r, (fun () -> r.GetBytes())) + else + None) - member _.GetRawTypeForwarders() = + member _.GetRawTypeForwarders() = match ilModule.Manifest with | Some manifest -> manifest.ExportedTypes | None -> mkILExportedTypes [] - member _.ShortAssemblyName = GetNameOfILModule ilModule + member _.ShortAssemblyName = GetNameOfILModule ilModule - member _.ILScopeRef = MakeScopeRefForILModule ilModule + member _.ILScopeRef = MakeScopeRefForILModule ilModule - member _.ILAssemblyRefs = ilAssemblyRefs + member _.ILAssemblyRefs = ilAssemblyRefs - member _.HasAnyFSharpSignatureDataAttribute = + member _.HasAnyFSharpSignatureDataAttribute = let attrs = GetCustomAttributesOfILModule ilModule List.exists IsSignatureDataVersionAttr attrs - member _.HasMatchingFSharpSignatureDataAttribute = + member _.HasMatchingFSharpSignatureDataAttribute = let attrs = GetCustomAttributesOfILModule ilModule - List.exists (IsMatchingSignatureDataVersionAttr (parseILVersion FSharpBinaryMetadataFormatRevision)) attrs + List.exists (IsMatchingSignatureDataVersionAttr(parseILVersion FSharpBinaryMetadataFormatRevision)) attrs //---------------------------------------------------------------------------- // TcImports //-------------------------------------------------------------------------- [] -type TcImportsSafeDisposal(tciLock: TcImportsLock, disposeActions: ResizeArray unit>,disposeTypeProviderActions: ResizeArray unit>) = +type TcImportsSafeDisposal + ( + tciLock: TcImportsLock, + disposeActions: ResizeArray unit>, + disposeTypeProviderActions: ResizeArray unit> + ) = let mutable isDisposed = false let dispose () = - tciLock.AcquireLock (fun tcitok -> + tciLock.AcquireLock(fun tcitok -> + + RequireTcImportsLock(tcitok, isDisposed) + RequireTcImportsLock(tcitok, disposeTypeProviderActions) + RequireTcImportsLock(tcitok, disposeActions) - RequireTcImportsLock (tcitok, isDisposed) - RequireTcImportsLock (tcitok, disposeTypeProviderActions) - RequireTcImportsLock (tcitok, disposeActions) + // disposing deliberately only closes this tcImports, not the ones up the chain + isDisposed <- true - // disposing deliberately only closes this tcImports, not the ones up the chain - isDisposed <- true - if verbose then - dprintf "disposing of TcImports, %d binaries\n" disposeActions.Count - - let actions1 = disposeTypeProviderActions |> Seq.toArray - let actions2 = disposeActions |> Seq.toArray + let actions1 = disposeTypeProviderActions |> Seq.toArray + let actions2 = disposeActions |> Seq.toArray - disposeTypeProviderActions.Clear() - disposeActions.Clear() + disposeTypeProviderActions.Clear() + disposeActions.Clear() - for action in actions1 do action() - for action in actions2 do action() - ) + for action in actions1 do + action () - override _.Finalize() = - dispose () + for action in actions2 do + action ()) + + override _.Finalize() = dispose () interface IDisposable with - member this.Dispose() = + member this.Dispose() = if not isDisposed then GC.SuppressFinalize this dispose () @@ -814,43 +1034,42 @@ type TcImportsSafeDisposal(tciLock: TcImportsLock, disposeActions: ResizeArray) = +and TcImportsWeakHack(tciLock: TcImportsLock, tcImports: WeakReference) = let mutable dllInfos: TcImportsDllInfoHack list = [] - member _.SetDllInfos (value: ImportedBinary list) = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, dllInfos) - dllInfos <- value |> List.map (fun x -> { FileName = x.FileName }) + member _.SetDllInfos(value: ImportedBinary list) = + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, dllInfos) + dllInfos <- value |> List.map (fun x -> { FileName = x.FileName })) member _.Base: TcImportsWeakHack option = match tcImports.TryGetTarget() with | true, strong -> match strong.Base with - | Some (baseTcImports: TcImports) -> - Some baseTcImports.Weak - | _ -> - None - | _ -> - None + | Some (baseTcImports: TcImports) -> Some baseTcImports.Weak + | _ -> None + | _ -> None member _.SystemRuntimeContainsType typeName = - match tcImports.TryGetTarget () with + match tcImports.TryGetTarget() with | true, strong -> strong.SystemRuntimeContainsType typeName | _ -> false #endif /// Represents a table of imported assemblies with their resolutions. /// Is a disposable object, but it is recommended not to explicitly call Dispose unless you absolutely know nothing will be using its contents after the disposal. /// Otherwise, simply allow the GC to collect this and it will properly call Dispose from the finalizer. -and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAssemblyResolutions, importsBase: TcImports option, dependencyProviderOpt: DependencyProvider option) +and [] TcImports + ( + tcConfigP: TcConfigProvider, + initialResolutions: TcAssemblyResolutions, + importsBase: TcImports option, + dependencyProviderOpt: DependencyProvider option + ) as this #if !NO_TYPEPROVIDERS - as this #endif - = + = let tciLock = TcImportsLock() @@ -865,18 +1084,20 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let disposeTypeProviderActions = ResizeArray() #if !NO_TYPEPROVIDERS - let mutable generatedTypeRoots = Dictionary() - let tcImportsWeak = TcImportsWeakHack (tciLock, WeakReference<_> this) + let mutable generatedTypeRoots = + Dictionary() + + let tcImportsWeak = TcImportsWeakHack(tciLock, WeakReference<_> this) #endif - let disposal = new TcImportsSafeDisposal(tciLock, disposeActions, disposeTypeProviderActions) + let disposal = + new TcImportsSafeDisposal(tciLock, disposeActions, disposeTypeProviderActions) //---- End protected by tciLock ------- let mutable disposed = false // this doesn't need locking, it's only for debugging let mutable tcGlobals = None // this doesn't need locking, it's set during construction of the TcImports - let CheckDisposed() = - if disposed then assert false + let CheckDisposed () = if disposed then assert false let dispose () = CheckDisposed() @@ -888,18 +1109,21 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // If the thunk remains unresolved add it back to the ccuThunks dictionary for further processing // If not then move on to the next thunk let fixupOrphanCcus () = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, ccuThunks) - let contents = ccuThunks |> Seq.toArray - let unsuccessful = - [ for ccuThunk, func in contents do - if ccuThunk.IsUnresolvedReference then - func() - if ccuThunk.IsUnresolvedReference then - yield (ccuThunk, func) ] - ccuThunks <- ResizeArray unsuccessful - - let availableToOptionalCcu = function + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, ccuThunks) + let contents = ccuThunks |> Seq.toArray + + let unsuccessful = + [ + for ccuThunk, func in contents do + if ccuThunk.IsUnresolvedReference then func () + if ccuThunk.IsUnresolvedReference then (ccuThunk, func) + ] + + ccuThunks <- ResizeArray unsuccessful) + + let availableToOptionalCcu = + function | ResolvedCcu ccu -> Some ccu | UnresolvedCcu _ -> None @@ -907,14 +1131,13 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let matchNameSpace (entityOpt: Entity option) n = match entityOpt with | None -> None - | Some entity -> - entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind n + | Some entity -> entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind n match (Some ccu.Contents, nsname) ||> List.fold matchNameSpace with | Some ns -> - match Map.tryFind tname ns.ModuleOrNamespaceType.TypesByMangledName with - | Some _ -> true - | None -> false + match Map.tryFind tname ns.ModuleOrNamespaceType.TypesByMangledName with + | Some _ -> true + | None -> false | None -> false member internal tcImports.Base = @@ -922,62 +1145,65 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse importsBase member tcImports.CcuTable = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, ccuTable) - CheckDisposed() - ccuTable + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, ccuTable) + CheckDisposed() + ccuTable) member tcImports.DllTable = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, dllTable) - CheckDisposed() - dllTable + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, dllTable) + CheckDisposed() + dllTable) #if !NO_TYPEPROVIDERS member tcImports.Weak = - CheckDisposed() - tcImportsWeak + CheckDisposed() + tcImportsWeak #endif member tcImports.RegisterCcu ccuInfo = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, ccuInfos) - RequireTcImportsLock(tcitok, ccuTable) - ccuInfos <- ccuInfos ++ ccuInfo - // Assembly Ref Resolution: remove this use of ccu.AssemblyName - ccuTable <- NameMap.add ccuInfo.FSharpViewOfMetadata.AssemblyName ccuInfo ccuTable + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, ccuInfos) + RequireTcImportsLock(tcitok, ccuTable) + ccuInfos <- ccuInfos ++ ccuInfo + // Assembly Ref Resolution: remove this use of ccu.AssemblyName + ccuTable <- NameMap.add ccuInfo.FSharpViewOfMetadata.AssemblyName ccuInfo ccuTable) member tcImports.RegisterDll dllInfo = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, dllInfos) - RequireTcImportsLock(tcitok, dllTable) - dllInfos <- dllInfos ++ dllInfo + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, dllInfos) + RequireTcImportsLock(tcitok, dllTable) + dllInfos <- dllInfos ++ dllInfo #if !NO_TYPEPROVIDERS - tcImportsWeak.SetDllInfos dllInfos + tcImportsWeak.SetDllInfos dllInfos #endif - dllTable <- NameMap.add (getNameOfScopeRef dllInfo.ILScopeRef) dllInfo dllTable + dllTable <- NameMap.add (getNameOfScopeRef dllInfo.ILScopeRef) dllInfo dllTable) member tcImports.GetDllInfos() : ImportedBinary list = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, dllInfos) - match importsBase with - | Some importsBase -> importsBase.GetDllInfos() @ dllInfos - | None -> dllInfos + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, dllInfos) + + match importsBase with + | Some importsBase -> importsBase.GetDllInfos() @ dllInfos + | None -> dllInfos) member tcImports.AllAssemblyResolutions() = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, resolutions) - let ars = resolutions.GetAssemblyResolutions() - match importsBase with - | Some importsBase-> importsBase.AllAssemblyResolutions() @ ars - | None -> ars + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, resolutions) + let ars = resolutions.GetAssemblyResolutions() + + match importsBase with + | Some importsBase -> importsBase.AllAssemblyResolutions() @ ars + | None -> ars) - member tcImports.TryFindDllInfo (ctok: CompilationThreadToken, m, assemblyName, lookupOnly) = + member tcImports.TryFindDllInfo(ctok: CompilationThreadToken, m, assemblyName, lookupOnly) = CheckDisposed() + let rec look (t: TcImports) = match NameMap.tryFind assemblyName t.DllTable with | Some res -> Some res @@ -985,75 +1211,82 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse match t.Base with | Some t2 -> look t2 | None -> None + match look tcImports with | Some res -> Some res | None -> tcImports.ImplicitLoadIfAllowed(ctok, m, assemblyName, lookupOnly) look tcImports - member tcImports.FindDllInfo (ctok, m, assemblyName) = - match tcImports.TryFindDllInfo (ctok, m, assemblyName, lookupOnly=false) with + member tcImports.FindDllInfo(ctok, m, assemblyName) = + match tcImports.TryFindDllInfo(ctok, m, assemblyName, lookupOnly = false) with | Some res -> res - | None -> error(Error(FSComp.SR.buildCouldNotResolveAssembly assemblyName, m)) + | None -> error (Error(FSComp.SR.buildCouldNotResolveAssembly assemblyName, m)) member tcImports.GetImportedAssemblies() = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, ccuInfos) - match importsBase with - | Some importsBase -> List.append (importsBase.GetImportedAssemblies()) ccuInfos - | None -> ccuInfos + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, ccuInfos) + + match importsBase with + | Some importsBase -> List.append (importsBase.GetImportedAssemblies()) ccuInfos + | None -> ccuInfos) member tcImports.GetCcusExcludingBase() = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, ccuInfos) - ccuInfos |> List.map (fun x -> x.FSharpViewOfMetadata) + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, ccuInfos) + ccuInfos |> List.map (fun x -> x.FSharpViewOfMetadata)) member tcImports.GetCcusInDeclOrder() = CheckDisposed() List.map (fun x -> x.FSharpViewOfMetadata) (tcImports.GetImportedAssemblies()) // This is the main "assembly reference --> assembly" resolution routine. - member tcImports.FindCcuInfo (ctok, m, assemblyName, lookupOnly) = + member tcImports.FindCcuInfo(ctok, m, assemblyName, lookupOnly) = CheckDisposed() + let rec look (t: TcImports) = match NameMap.tryFind assemblyName t.CcuTable with | Some res -> Some res | None -> - match t.Base with - | Some t2 -> look t2 - | None -> None + match t.Base with + | Some t2 -> look t2 + | None -> None match look tcImports with | Some res -> ResolvedImportedAssembly res | None -> tcImports.ImplicitLoadIfAllowed(ctok, m, assemblyName, lookupOnly) + match look tcImports with | Some res -> ResolvedImportedAssembly res | None -> UnresolvedImportedAssembly assemblyName - member tcImports.FindCcu (ctok, m, assemblyName, lookupOnly) = + member tcImports.FindCcu(ctok, m, assemblyName, lookupOnly) = CheckDisposed() + match tcImports.FindCcuInfo(ctok, m, assemblyName, lookupOnly) with | ResolvedImportedAssembly importedAssembly -> ResolvedCcu(importedAssembly.FSharpViewOfMetadata) | UnresolvedImportedAssembly assemblyName -> UnresolvedCcu assemblyName member tcImports.FindCcuFromAssemblyRef(ctok, m, assemblyRef: ILAssemblyRef) = CheckDisposed() - match tcImports.FindCcuInfo(ctok, m, assemblyRef.Name, lookupOnly=false) with + + match tcImports.FindCcuInfo(ctok, m, assemblyRef.Name, lookupOnly = false) with | ResolvedImportedAssembly importedAssembly -> ResolvedCcu(importedAssembly.FSharpViewOfMetadata) | UnresolvedImportedAssembly _ -> UnresolvedCcu(assemblyRef.QualifiedName) member tcImports.TryFindXmlDocumentationInfo(assemblyName: string) = CheckDisposed() + let rec look (t: TcImports) = match NameMap.tryFind assemblyName t.CcuTable with | Some res -> Some res | None -> - match t.Base with - | Some t2 -> look t2 - | None -> None + match t.Base with + | Some t2 -> look t2 + | None -> None match look tcImports with | Some res -> res.FSharpViewOfMetadata.Deref.XmlDocumentationInfo @@ -1062,106 +1295,129 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse #if !NO_TYPEPROVIDERS member tcImports.GetProvidedAssemblyInfo(ctok, m, assembly: Tainted) = match assembly with - | Tainted.Null -> false,None + | Tainted.Null -> false, None | Tainted.NonNull assembly -> - let aname = assembly.PUntaint((fun a -> a.GetName()), m) - let ilShortAssemName = aname.Name + let aname = assembly.PUntaint((fun a -> a.GetName()), m) + let ilShortAssemName = aname.Name + + match tcImports.FindCcu(ctok, m, ilShortAssemName, lookupOnly = true) with + | ResolvedCcu ccu -> + if ccu.IsProviderGenerated then + let dllinfo = tcImports.FindDllInfo(ctok, m, ilShortAssemName) + true, dllinfo.ProviderGeneratedStaticLinkMap + else + false, None + + | UnresolvedCcu _ -> + let g = tcImports.GetTcGlobals() + let ilScopeRef = ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName aname) + let fileName = aname.Name + ".dll" + + let bytes = + assembly + .PApplyWithProvider((fun (assembly, provider) -> assembly.GetManifestModuleContents provider), m) + .PUntaint(id, m) + + let tcConfig = tcConfigP.Get ctok + + let ilModule, ilAssemblyRefs = + let opts: ILReaderOptions = + { + reduceMemoryUsage = tcConfig.reduceMemoryUsage + pdbDirPath = None + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = tcConfig.tryGetMetadataSnapshot + } + + let reader = OpenILModuleReaderFromBytes fileName bytes opts + reader.ILModuleDef, reader.ILAssemblyRefs + + let theActualAssembly = assembly.PUntaint((fun x -> x.Handle), m) + + let dllinfo = + { + RawMetadata = RawFSharpAssemblyDataBackedByFileOnDisk(ilModule, ilAssemblyRefs) + FileName = fileName + ProviderGeneratedAssembly = Some theActualAssembly + IsProviderGenerated = true + ProviderGeneratedStaticLinkMap = + if g.isInteractive then + None + else + Some(ProvidedAssemblyStaticLinkingMap.CreateNew()) + ILScopeRef = ilScopeRef + ILAssemblyRefs = ilAssemblyRefs + } - match tcImports.FindCcu (ctok, m, ilShortAssemName, lookupOnly=true) with - | ResolvedCcu ccu -> - if ccu.IsProviderGenerated then - let dllinfo = tcImports.FindDllInfo(ctok, m, ilShortAssemName) - true, dllinfo.ProviderGeneratedStaticLinkMap - else - false, None + tcImports.RegisterDll dllinfo - | UnresolvedCcu _ -> - let g = tcImports.GetTcGlobals() - let ilScopeRef = ILScopeRef.Assembly (ILAssemblyRef.FromAssemblyName aname) - let fileName = aname.Name + ".dll" - let bytes = assembly.PApplyWithProvider((fun (assembly, provider) -> assembly.GetManifestModuleContents provider), m).PUntaint(id, m) - let tcConfig = tcConfigP.Get ctok - let ilModule, ilAssemblyRefs = - let opts: ILReaderOptions = - { reduceMemoryUsage = tcConfig.reduceMemoryUsage - pdbDirPath = None - metadataOnly = MetadataOnlyFlag.Yes - tryGetMetadataSnapshot = tcConfig.tryGetMetadataSnapshot } - let reader = OpenILModuleReaderFromBytes fileName bytes opts - reader.ILModuleDef, reader.ILAssemblyRefs - - let theActualAssembly = assembly.PUntaint((fun x -> x.Handle), m) - let dllinfo = - { RawMetadata= RawFSharpAssemblyDataBackedByFileOnDisk (ilModule, ilAssemblyRefs) - FileName=fileName - ProviderGeneratedAssembly=Some theActualAssembly - IsProviderGenerated=true - ProviderGeneratedStaticLinkMap= if g.isInteractive then None else Some (ProvidedAssemblyStaticLinkingMap.CreateNew()) - ILScopeRef = ilScopeRef - ILAssemblyRefs = ilAssemblyRefs } - tcImports.RegisterDll dllinfo - - let ccuContents = Construct.NewCcuContents ilScopeRef m ilShortAssemName (Construct.NewEmptyModuleOrNamespaceType Namespace) - - let ccuData: CcuData = - { IsFSharp=false - UsesFSharp20PlusQuotations=false - InvalidateEvent=(Event<_>()).Publish - IsProviderGenerated = true - QualifiedName= Some (assembly.PUntaint((fun a -> a.FullName), m)) - Contents = ccuContents - ILScopeRef = ilScopeRef - Stamp = newStamp() - SourceCodeDirectory = "" - FileName = Some fileName - MemberSignatureEquality = (fun ty1 ty2 -> typeEquivAux EraseAll g ty1 ty2) - ImportProvidedType = (fun ty -> ImportProvidedType (tcImports.GetImportMap()) m ty) - TryGetILModuleDef = (fun () -> Some ilModule) - TypeForwarders = CcuTypeForwarderTable.Empty - XmlDocumentationInfo = - match tcConfig.xmlDocInfoLoader with - | Some xmlDocInfoLoader -> xmlDocInfoLoader.TryLoad(fileName) - | _ -> None - } - - let ccu = CcuThunk.Create(ilShortAssemName, ccuData) - let ccuinfo = - { FSharpViewOfMetadata=ccu - ILScopeRef = ilScopeRef - AssemblyAutoOpenAttributes = [] - AssemblyInternalsVisibleToAttributes = [] - IsProviderGenerated = true - TypeProviders=[] - FSharpOptimizationData = notlazy None } - tcImports.RegisterCcu ccuinfo - // Yes, it is generative - true, dllinfo.ProviderGeneratedStaticLinkMap + let ccuContents = + Construct.NewCcuContents ilScopeRef m ilShortAssemName (Construct.NewEmptyModuleOrNamespaceType Namespace) + + let ccuData: CcuData = + { + IsFSharp = false + UsesFSharp20PlusQuotations = false + InvalidateEvent = (Event<_>()).Publish + IsProviderGenerated = true + QualifiedName = Some(assembly.PUntaint((fun a -> a.FullName), m)) + Contents = ccuContents + ILScopeRef = ilScopeRef + Stamp = newStamp () + SourceCodeDirectory = "" + FileName = Some fileName + MemberSignatureEquality = (fun ty1 ty2 -> typeEquivAux EraseAll g ty1 ty2) + ImportProvidedType = (fun ty -> ImportProvidedType (tcImports.GetImportMap()) m ty) + TryGetILModuleDef = (fun () -> Some ilModule) + TypeForwarders = CcuTypeForwarderTable.Empty + XmlDocumentationInfo = + match tcConfig.xmlDocInfoLoader with + | Some xmlDocInfoLoader -> xmlDocInfoLoader.TryLoad(fileName) + | _ -> None + } + + let ccu = CcuThunk.Create(ilShortAssemName, ccuData) + + let ccuinfo = + { + FSharpViewOfMetadata = ccu + ILScopeRef = ilScopeRef + AssemblyAutoOpenAttributes = [] + AssemblyInternalsVisibleToAttributes = [] + IsProviderGenerated = true + TypeProviders = [] + FSharpOptimizationData = notlazy None + } + + tcImports.RegisterCcu ccuinfo + // Yes, it is generative + true, dllinfo.ProviderGeneratedStaticLinkMap member tcImports.RecordGeneratedTypeRoot root = - tciLock.AcquireLock <| fun tcitok -> - // checking if given ProviderGeneratedType was already recorded before (probably for another set of static parameters) - let (ProviderGeneratedType(_, ilTyRef, _)) = root - let index = - RequireTcImportsLock(tcitok, generatedTypeRoots) - match generatedTypeRoots.TryGetValue ilTyRef with - | true, (index, _) -> index - | false, _ -> generatedTypeRoots.Count - generatedTypeRoots[ilTyRef] <- (index, root) + tciLock.AcquireLock(fun tcitok -> + // checking if given ProviderGeneratedType was already recorded before (probably for another set of static parameters) + let (ProviderGeneratedType (_, ilTyRef, _)) = root + + let index = + RequireTcImportsLock(tcitok, generatedTypeRoots) + + match generatedTypeRoots.TryGetValue ilTyRef with + | true, (index, _) -> index + | false, _ -> generatedTypeRoots.Count + + generatedTypeRoots[ilTyRef] <- (index, root)) member tcImports.ProviderGeneratedTypeRoots = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, generatedTypeRoots) - generatedTypeRoots.Values - |> Seq.sortBy fst - |> Seq.map snd - |> Seq.toList + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, generatedTypeRoots) + generatedTypeRoots.Values |> Seq.sortBy fst |> Seq.map snd |> Seq.toList) #endif member private tcImports.AttachDisposeAction action = - tciLock.AcquireLock <| fun tcitok -> - CheckDisposed() - RequireTcImportsLock(tcitok, disposeActions) - disposeActions.Add action + tciLock.AcquireLock(fun tcitok -> + CheckDisposed() + RequireTcImportsLock(tcitok, disposeActions) + disposeActions.Add action) #if !NO_TYPEPROVIDERS member private tcImports.AttachDisposeTypeProviderAction action = @@ -1172,60 +1428,85 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // Note: the returned binary reader is associated with the tcImports, i.e. when the tcImports are closed // then the reader is closed. member tcImports.OpenILBinaryModule(ctok, fileName, m) = - try - CheckDisposed() - let tcConfig = tcConfigP.Get ctok - let pdbDirPath = - // We open the pdb file if one exists parallel to the binary we - // are reading, so that --standalone will preserve debug information. - if tcConfig.openDebugInformationForLaterStaticLinking then - let pdbDir = try FileSystem.GetDirectoryNameShim fileName with _ -> "." - let pdbFile = (try FileSystemUtils.chopExtension fileName with _ -> fileName) + ".pdb" - - if FileSystem.FileExistsShim pdbFile then - if verbose then dprintf "reading PDB file %s from directory %s\n" pdbFile pdbDir - Some pdbDir + try + CheckDisposed() + let tcConfig = tcConfigP.Get ctok + + let pdbDirPath = + // We open the pdb file if one exists parallel to the binary we + // are reading, so that --standalone will preserve debug information. + if tcConfig.openDebugInformationForLaterStaticLinking then + let pdbDir = + try + FileSystem.GetDirectoryNameShim fileName + with _ -> + "." + + let pdbFile = + (try + FileSystemUtils.chopExtension fileName + with _ -> + fileName) + + ".pdb" + + if FileSystem.FileExistsShim pdbFile then + Some pdbDir + else + None else None - else - None - let ilILBinaryReader = - OpenILBinary (fileName, tcConfig.reduceMemoryUsage, pdbDirPath, tcConfig.shadowCopyReferences, tcConfig.tryGetMetadataSnapshot) + let ilILBinaryReader = + OpenILBinary( + fileName, + tcConfig.reduceMemoryUsage, + pdbDirPath, + tcConfig.shadowCopyReferences, + tcConfig.tryGetMetadataSnapshot + ) - tcImports.AttachDisposeAction(fun _ -> (ilILBinaryReader :> IDisposable).Dispose()) - ilILBinaryReader.ILModuleDef, ilILBinaryReader.ILAssemblyRefs - with e -> - error(Error(FSComp.SR.buildErrorOpeningBinaryFile(fileName, e.Message), m)) + tcImports.AttachDisposeAction(fun _ -> (ilILBinaryReader :> IDisposable).Dispose()) + ilILBinaryReader.ILModuleDef, ilILBinaryReader.ILAssemblyRefs + with e -> + error (Error(FSComp.SR.buildErrorOpeningBinaryFile (fileName, e.Message), m)) (* auxModTable is used for multi-module assemblies *) member tcImports.MkLoaderForMultiModuleILAssemblies ctok m = CheckDisposed() let auxModTable = HashMultiMap(10, HashIdentity.Structural) + fun viewedScopeRef -> let tcConfig = tcConfigP.Get ctok + match viewedScopeRef with | ILScopeRef.Module modref -> let key = modref.Name + if not (auxModTable.ContainsKey key) then - let resolution = tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.RaiseError, AssemblyReference(m, key, None)) |> Option.get + let resolution = + tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.RaiseError, AssemblyReference(m, key, None)) + |> Option.get + let ilModule, _ = tcImports.OpenILBinaryModule(ctok, resolution.resolvedPath, m) auxModTable[key] <- ilModule + auxModTable[key] - | _ -> - error(InternalError("Unexpected ILScopeRef.Local or ILScopeRef.Assembly in exported type table", m)) + | _ -> error (InternalError("Unexpected ILScopeRef.Local or ILScopeRef.Assembly in exported type table", m)) member tcImports.IsAlreadyRegistered nm = CheckDisposed() - tcImports.GetDllInfos() |> List.exists (fun dll -> + + tcImports.GetDllInfos() + |> List.exists (fun dll -> match dll.ILScopeRef with | ILScopeRef.Assembly a -> a.Name = nm | _ -> false) member _.DependencyProvider = CheckDisposed() + match dependencyProviderOpt with | None -> Debug.Assert(false, "this should never be called on FrameworkTcImports") @@ -1234,22 +1515,30 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse member tcImports.GetImportMap() = CheckDisposed() + let loaderInterface = +#if NO_TYPEPROVIDERS { new AssemblyLoader with - member _.FindCcuFromAssemblyRef (ctok, m, ilAssemblyRef) = - tcImports.FindCcuFromAssemblyRef (ctok, m, ilAssemblyRef) + member _.FindCcuFromAssemblyRef(ctok, m, ilAssemblyRef) = + tcImports.FindCcuFromAssemblyRef(ctok, m, ilAssemblyRef) - member _.TryFindXmlDocumentationInfo assemblyName = + member _.TryFindXmlDocumentationInfo assemblyName = tcImports.TryFindXmlDocumentationInfo(assemblyName) + } +#else + { new AssemblyLoader with + member _.FindCcuFromAssemblyRef(ctok, m, ilAssemblyRef) = + tcImports.FindCcuFromAssemblyRef(ctok, m, ilAssemblyRef) -#if !NO_TYPEPROVIDERS - member _.GetProvidedAssemblyInfo (ctok, m, assembly) = - tcImports.GetProvidedAssemblyInfo (ctok, m, assembly) + member _.TryFindXmlDocumentationInfo assemblyName = + tcImports.TryFindXmlDocumentationInfo(assemblyName) + + member _.GetProvidedAssemblyInfo(ctok, m, assembly) = + tcImports.GetProvidedAssemblyInfo(ctok, m, assembly) - member _.RecordGeneratedTypeRoot root = - tcImports.RecordGeneratedTypeRoot root + member _.RecordGeneratedTypeRoot root = tcImports.RecordGeneratedTypeRoot root + } #endif - } ImportMap(tcImports.GetTcGlobals(), loaderInterface) // Note the tcGlobals are only available once mscorlib and fslib have been established. For TcImports, @@ -1262,6 +1551,7 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // ImportILAssembly had a tcGlobals available when it really needs it. member tcImports.GetTcGlobals() : TcGlobals = CheckDisposed() + match tcGlobals with | Some g -> g | None -> @@ -1275,26 +1565,59 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse #if !NO_TYPEPROVIDERS member private tcImports.InjectProvidedNamespaceOrTypeIntoEntity - (typeProviderEnvironment, - tcConfig: TcConfig, - m, entity: Entity, - injectedNamespace, remainingNamespace, - provider, - st: Tainted option) = + ( + typeProviderEnvironment, + tcConfig: TcConfig, + m, + entity: Entity, + injectedNamespace, + remainingNamespace, + provider, + st: Tainted option + ) = match remainingNamespace with | next :: rest -> // Inject the namespace entity match entity.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind next with | Some childEntity -> - tcImports.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, childEntity, next :: injectedNamespace, rest, provider, st) + tcImports.InjectProvidedNamespaceOrTypeIntoEntity( + typeProviderEnvironment, + tcConfig, + m, + childEntity, + next :: injectedNamespace, + rest, + provider, + st + ) | None -> // Build up the artificial namespace if there is not a real one. - let cpath = CompPath(ILScopeRef.Local, injectedNamespace |> List.rev |> List.map (fun n -> (n, ModuleOrNamespaceKind.Namespace)) ) + let cpath = + CompPath( + ILScopeRef.Local, + injectedNamespace + |> List.rev + |> List.map (fun n -> (n, ModuleOrNamespaceKind.Namespace)) + ) + let mid = ident (next, rangeStartup) let mty = Construct.NewEmptyModuleOrNamespaceType Namespace - let newNamespace = Construct.NewModuleOrNamespace (Some cpath) taccessPublic mid XmlDoc.Empty [] (MaybeLazy.Strict mty) + + let newNamespace = + Construct.NewModuleOrNamespace (Some cpath) taccessPublic mid XmlDoc.Empty [] (MaybeLazy.Strict mty) + entity.ModuleOrNamespaceType.AddModuleOrNamespaceByMutation newNamespace - tcImports.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, newNamespace, next :: injectedNamespace, rest, provider, st) + + tcImports.InjectProvidedNamespaceOrTypeIntoEntity( + typeProviderEnvironment, + tcConfig, + m, + newNamespace, + next :: injectedNamespace, + rest, + provider, + st + ) | [] -> match st with | Some st -> @@ -1302,21 +1625,26 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // // Generated types get properly injected into the provided (i.e. generated) assembly CCU in tc.fs - let importProvidedType t = ImportProvidedType (tcImports.GetImportMap()) m t - let isSuppressRelocate = tcConfig.isInteractive || st.PUntaint((fun st -> st.IsSuppressRelocate), m) - let newEntity = Construct.NewProvidedTycon(typeProviderEnvironment, st, importProvidedType, isSuppressRelocate, m) + let importProvidedType t = + ImportProvidedType (tcImports.GetImportMap()) m t + + let isSuppressRelocate = + tcConfig.isInteractive || st.PUntaint((fun st -> st.IsSuppressRelocate), m) + + let newEntity = + Construct.NewProvidedTycon(typeProviderEnvironment, st, importProvidedType, isSuppressRelocate, m) + entity.ModuleOrNamespaceType.AddProvidedTypeEntity newEntity | None -> () entity.entity_tycon_repr <- match entity.TypeReprInfo with // This is the first extension - | TNoRepr -> - TProvidedNamespaceRepr(typeProviderEnvironment, [provider]) + | TNoRepr -> TProvidedNamespaceRepr(typeProviderEnvironment, [ provider ]) // Add to the existing list of extensions - | TProvidedNamespaceRepr(resolutionFolder, prior) as repr -> - if not(prior |> List.exists(fun r->Tainted.EqTainted r provider)) then + | TProvidedNamespaceRepr (resolutionFolder, prior) as repr -> + if not (prior |> List.exists (fun r -> Tainted.EqTainted r provider)) then TProvidedNamespaceRepr(resolutionFolder, provider :: prior) else repr @@ -1324,11 +1652,16 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse | _ -> failwith "Unexpected representation in namespace entity referred to by a type provider" member tcImportsStrong.ImportTypeProviderExtensions - (ctok, tcConfig: TcConfig, - fileNameOfRuntimeAssembly, - ilScopeRefOfRuntimeAssembly, - runtimeAssemblyAttributes: ILAttribute list, - entityToInjectInto, invalidateCcu: Event<_>, m) = + ( + ctok, + tcConfig: TcConfig, + fileNameOfRuntimeAssembly, + ilScopeRefOfRuntimeAssembly, + runtimeAssemblyAttributes: ILAttribute list, + entityToInjectInto, + invalidateCcu: Event<_>, + m + ) = let startingErrorCount = DiagnosticsThreadStatics.DiagnosticsLogger.ErrorCount @@ -1338,27 +1671,38 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse runtimeAssemblyAttributes |> List.choose TryDecodeTypeProviderAssemblyAttr // If no design-time assembly is specified, use the runtime assembly - |> List.map (function Null -> fileNameOfRuntimeAssembly | NonNull s -> s) + |> List.map (function + | Null -> fileNameOfRuntimeAssembly + | NonNull s -> s) // For each simple name of a design-time assembly, we take the first matching one in the order they are // specified in the attributes - |> List.distinctBy (fun s -> try Path.GetFileNameWithoutExtension s with _ -> s) + |> List.distinctBy (fun s -> + try + Path.GetFileNameWithoutExtension s + with _ -> + s) if not (List.isEmpty designTimeAssemblyNames) then // Find the SystemRuntimeAssemblyVersion value to report in the TypeProviderConfig. let primaryAssemblyVersion = let primaryAssemblyRef = tcConfig.PrimaryAssemblyDllReference() - let resolution = tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.RaiseError, primaryAssemblyRef) |> Option.get - // MSDN: this method causes the file to be opened and closed, but the assembly is not added to this domain + + let resolution = + tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.RaiseError, primaryAssemblyRef) + |> Option.get + // MSDN: this method causes the file to be opened and closed, but the assembly is not added to this domain let name = System.Reflection.AssemblyName.GetAssemblyName(resolution.resolvedPath) name.Version let typeProviderEnvironment = - { ResolutionFolder = tcConfig.implicitIncludeDir - OutputFile = tcConfig.outputFile - ShowResolutionMessages = tcConfig.showExtensionTypeMessages - ReferencedAssemblies = Array.distinct [| for r in tcImportsStrong.AllAssemblyResolutions() -> r.resolvedPath |] - TemporaryFolder = FileSystem.GetTempPathShim() } + { + ResolutionFolder = tcConfig.implicitIncludeDir + OutputFile = tcConfig.outputFile + ShowResolutionMessages = tcConfig.showExtensionTypeMessages + ReferencedAssemblies = Array.distinct [| for r in tcImportsStrong.AllAssemblyResolutions() -> r.resolvedPath |] + TemporaryFolder = FileSystem.GetTempPathShim() + } // The type provider should not hold strong references to disposed // TcImport objects. So the callbacks provided in the type provider config @@ -1367,22 +1711,32 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let systemRuntimeContainsType = // NOTE: do not touch this, edit: but we did, we had no choice - TPs cannot hold a strong reference on TcImports "ever". let tcImports = tcImportsWeak - let mutable systemRuntimeContainsTypeRef = fun typeName -> tcImports.SystemRuntimeContainsType typeName - tcImportsStrong.AttachDisposeTypeProviderAction(fun () -> systemRuntimeContainsTypeRef <- fun _ -> raise (ObjectDisposedException("The type provider has been disposed"))) + + let mutable systemRuntimeContainsTypeRef = + fun typeName -> tcImports.SystemRuntimeContainsType typeName + + tcImportsStrong.AttachDisposeTypeProviderAction(fun () -> + systemRuntimeContainsTypeRef <- fun _ -> raise (ObjectDisposedException("The type provider has been disposed"))) + fun arg -> systemRuntimeContainsTypeRef arg - let providers = [ - for designTimeAssemblyName in designTimeAssemblyNames do - yield! GetTypeProvidersOfAssembly(fileNameOfRuntimeAssembly, - ilScopeRefOfRuntimeAssembly, - designTimeAssemblyName, - typeProviderEnvironment, - tcConfig.isInvalidationSupported, - tcConfig.isInteractive, - systemRuntimeContainsType, - primaryAssemblyVersion, - tcConfig.compilerToolPaths, - m) ] + let providers = + [ + for designTimeAssemblyName in designTimeAssemblyNames do + yield! + GetTypeProvidersOfAssembly( + fileNameOfRuntimeAssembly, + ilScopeRefOfRuntimeAssembly, + designTimeAssemblyName, + typeProviderEnvironment, + tcConfig.isInvalidationSupported, + tcConfig.isInteractive, + systemRuntimeContainsType, + primaryAssemblyVersion, + tcConfig.compilerToolPaths, + m + ) + ] // Note, type providers are disposable objects. The TcImports owns the provider objects - when/if it is disposed, the providers are disposed. // We ignore all exceptions from provider disposal. for provider in providers do @@ -1394,38 +1748,52 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // Add the invalidation signal handlers to each provider for provider in providers do - provider.PUntaint((fun tp -> - - // Register the type provider invalidation handler. - // - // We are explicit about what the handler closure captures to help reason about the - // lifetime of captured objects, especially in case the type provider instance gets leaked - // or keeps itself alive mistakenly, e.g. via some global state in the type provider instance. - // - // The closure captures - // 1. an Event value, ultimately this is made available in all CCus as ccu.InvalidateEvent - // 2. any handlers registered to ccu.InvalidateEvent - // 3. a message string - // - // Note that the invalidation handler does not explicitly capture the TcImports. - // The only place where handlers are registered is to ccu.InvalidateEvent is in IncrementalBuilder.fs. - - let capturedInvalidateCcu = invalidateCcu - let capturedMessage = "The provider '" + fileNameOfRuntimeAssembly + "' reported a change" - let handler = tp.Invalidate.Subscribe(fun _ -> capturedInvalidateCcu.Trigger capturedMessage) - - // When the TcImports is disposed we detach the invalidation callback - tcImportsStrong.AttachDisposeTypeProviderAction(fun () -> try handler.Dispose() with _ -> ())), m) + provider.PUntaint( + (fun tp -> + + // Register the type provider invalidation handler. + // + // We are explicit about what the handler closure captures to help reason about the + // lifetime of captured objects, especially in case the type provider instance gets leaked + // or keeps itself alive mistakenly, e.g. via some global state in the type provider instance. + // + // The closure captures + // 1. an Event value, ultimately this is made available in all CCus as ccu.InvalidateEvent + // 2. any handlers registered to ccu.InvalidateEvent + // 3. a message string + // + // Note that the invalidation handler does not explicitly capture the TcImports. + // The only place where handlers are registered is to ccu.InvalidateEvent is in IncrementalBuilder.fs. + + let capturedInvalidateCcu = invalidateCcu + + let capturedMessage = + "The provider '" + fileNameOfRuntimeAssembly + "' reported a change" + + let handler = + tp.Invalidate.Subscribe(fun _ -> capturedInvalidateCcu.Trigger capturedMessage) + + // When the TcImports is disposed we detach the invalidation callback + tcImportsStrong.AttachDisposeTypeProviderAction(fun () -> + try + handler.Dispose() + with _ -> + ())), + m + ) match providers with | [] -> - warning(Error(FSComp.SR.etHostingAssemblyFoundWithoutHosts(fileNameOfRuntimeAssembly, typeof.FullName), m)) + let typeName = typeof.FullName + warning (Error(FSComp.SR.etHostingAssemblyFoundWithoutHosts (fileNameOfRuntimeAssembly, typeName), m)) | _ -> #if DEBUG if typeProviderEnvironment.ShowResolutionMessages then dprintfn "Found extension type hosting hosting assembly '%s' with the following extensions:" fileNameOfRuntimeAssembly - providers |> List.iter(fun provider ->dprintfn " %s" (DisplayNameOfTypeProvider(provider.TypeProvider, m))) + + providers + |> List.iter (fun provider -> dprintfn " %s" (DisplayNameOfTypeProvider(provider.TypeProvider, m))) #endif for provider in providers do @@ -1433,39 +1801,69 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // Inject an entity for the namespace, or if one already exists, then record this as a provider // for that namespace. let rec loop (providedNamespace: Tainted) = - let path = GetProvidedNamespaceAsPath(m, provider, providedNamespace.PUntaint((fun r -> r.NamespaceName), m)) - tcImportsStrong.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, entityToInjectInto, [], path, provider, None) + let path = + GetProvidedNamespaceAsPath(m, provider, providedNamespace.PUntaint((fun r -> r.NamespaceName), m)) + + tcImportsStrong.InjectProvidedNamespaceOrTypeIntoEntity( + typeProviderEnvironment, + tcConfig, + m, + entityToInjectInto, + [], + path, + provider, + None + ) // Inject entities for the types returned by provider.GetTypes(). // // NOTE: The types provided by GetTypes() are available for name resolution // when the namespace is "opened". This is part of the specification of the language // feature. - let tys = providedNamespace.PApplyArray((fun provider -> provider.GetTypes()), "GetTypes", m) - let ptys = [| for ty in tys -> ty.PApply((fun ty -> ty |> ProvidedType.CreateNoContext), m) |] - for st in ptys do - tcImportsStrong.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, entityToInjectInto, [], path, provider, Some st) + let tys = + providedNamespace.PApplyArray((fun provider -> provider.GetTypes()), "GetTypes", m) + + let ptys = + [| + for ty in tys -> ty.PApply((fun ty -> ty |> ProvidedType.CreateNoContext), m) + |] - for providedNestedNamespace in providedNamespace.PApplyArray((fun provider -> provider.GetNestedNamespaces()), "GetNestedNamespaces", m) do + for st in ptys do + tcImportsStrong.InjectProvidedNamespaceOrTypeIntoEntity( + typeProviderEnvironment, + tcConfig, + m, + entityToInjectInto, + [], + path, + provider, + Some st + ) + + for providedNestedNamespace in + providedNamespace.PApplyArray((fun provider -> provider.GetNestedNamespaces()), "GetNestedNamespaces", m) do loop providedNestedNamespace RequireCompilationThread ctok // IProvidedType.GetNamespaces is an example of a type provider call - let providedNamespaces = provider.PApplyArray((fun r -> r.GetNamespaces()), "GetNamespaces", m) + + let providedNamespaces = + provider.PApplyArray((fun r -> r.GetNamespaces()), "GetNamespaces", m) for providedNamespace in providedNamespaces do loop providedNamespace with e -> errorRecovery e m - if startingErrorCount Option.isSome @@ -1477,43 +1875,55 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // Compact Framework binaries must use this. However it is not // clear when else it is required, e.g. for Mono. - member tcImports.PrepareToImportReferencedILAssembly (ctok, m, fileName, dllinfo: ImportedBinary) = + member tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo: ImportedBinary) = CheckDisposed() let tcConfig = tcConfigP.Get ctok assert dllinfo.RawMetadata.TryGetILModuleDef().IsSome let ilModule = dllinfo.RawMetadata.TryGetILModuleDef().Value let ilScopeRef = dllinfo.ILScopeRef - let aref = - match ilScopeRef with - | ILScopeRef.Assembly aref -> aref - | _ -> error(InternalError("PrepareToImportReferencedILAssembly: cannot reference .NET netmodules directly, reference the containing assembly instead", m)) - - let nm = aref.Name - if verbose then dprintn ("Converting IL assembly to F# data structures "+nm) let auxModuleLoader = tcImports.MkLoaderForMultiModuleILAssemblies ctok m let invalidateCcu = Event<_>() - let ccu = ImportILAssembly(tcImports.GetImportMap, m, auxModuleLoader, tcConfig.xmlDocInfoLoader, ilScopeRef, tcConfig.implicitIncludeDir, Some fileName, ilModule, invalidateCcu.Publish) + + let ccu = + ImportILAssembly( + tcImports.GetImportMap, + m, + auxModuleLoader, + tcConfig.xmlDocInfoLoader, + ilScopeRef, + tcConfig.implicitIncludeDir, + Some fileName, + ilModule, + invalidateCcu.Publish + ) let ccuinfo = - { FSharpViewOfMetadata=ccu - ILScopeRef = ilScopeRef - AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilModule - AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilModule + { + FSharpViewOfMetadata = ccu + ILScopeRef = ilScopeRef + AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilModule + AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilModule #if !NO_TYPEPROVIDERS - IsProviderGenerated = false - TypeProviders = [] + IsProviderGenerated = false + TypeProviders = [] #endif - FSharpOptimizationData = notlazy None } + FSharpOptimizationData = notlazy None + } + tcImports.RegisterCcu ccuinfo let phase2 () = #if !NO_TYPEPROVIDERS - ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (ctok, tcConfig, fileName, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList(), ccu.Contents, invalidateCcu, m) + let attrs = ilModule.ManifestOfAssembly.CustomAttrs.AsList() + + ccuinfo.TypeProviders <- + tcImports.ImportTypeProviderExtensions(ctok, tcConfig, fileName, ilScopeRef, attrs, ccu.Contents, invalidateCcu, m) #endif - [ResolvedImportedAssembly ccuinfo] + [ ResolvedImportedAssembly ccuinfo ] + phase2 - member tcImports.PrepareToImportReferencedFSharpAssembly (ctok, m, fileName, dllinfo: ImportedBinary) = + member tcImports.PrepareToImportReferencedFSharpAssembly(ctok, m, fileName, dllinfo: ImportedBinary) = CheckDisposed() #if !NO_TYPEPROVIDERS let tcConfig = tcConfigP.Get ctok @@ -1521,14 +1931,15 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let ilModule = dllinfo.RawMetadata let ilScopeRef = dllinfo.ILScopeRef let ilShortAssemName = getNameOfScopeRef ilScopeRef - if verbose then dprintn ("Converting F# assembly to F# data structures "+(getNameOfScopeRef ilScopeRef)) - if verbose then dprintn ("Relinking interface info from F# assembly "+ilShortAssemName) - let optDataReaders = ilModule.GetRawFSharpOptimizationData(m, ilShortAssemName, fileName) + + let optDataReaders = + ilModule.GetRawFSharpOptimizationData(m, ilShortAssemName, fileName) let ccuRawDataAndInfos = ilModule.GetRawFSharpSignatureData(m, ilShortAssemName, fileName) |> List.map (fun (ccuName, sigDataReader) -> - let data = GetSignatureData (fileName, ilScopeRef, ilModule.TryGetILModuleDef(), sigDataReader) + let data = + GetSignatureData(fileName, ilScopeRef, ilModule.TryGetILModuleDef(), sigDataReader) let optDatas = Map.ofList optDataReaders @@ -1540,27 +1951,30 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse #endif let codeDir = minfo.compileTimeWorkingDir + + // note: for some fields we fix up this information later let ccuData: CcuData = - { ILScopeRef=ilScopeRef - Stamp = newStamp() - FileName = Some fileName - QualifiedName= Some(ilScopeRef.QualifiedName) - SourceCodeDirectory = codeDir (* note: in some cases we fix up this information later *) - IsFSharp=true - Contents = mspec + { + ILScopeRef = ilScopeRef + Stamp = newStamp () + FileName = Some fileName + QualifiedName = Some(ilScopeRef.QualifiedName) + SourceCodeDirectory = codeDir + IsFSharp = true + Contents = mspec #if !NO_TYPEPROVIDERS - InvalidateEvent=invalidateCcu.Publish - IsProviderGenerated = false - ImportProvidedType = (fun ty -> ImportProvidedType (tcImports.GetImportMap()) m ty) + InvalidateEvent = invalidateCcu.Publish + IsProviderGenerated = false + ImportProvidedType = (fun ty -> ImportProvidedType (tcImports.GetImportMap()) m ty) #endif - TryGetILModuleDef = ilModule.TryGetILModuleDef - UsesFSharp20PlusQuotations = minfo.usesQuotations - MemberSignatureEquality= (fun ty1 ty2 -> typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) - TypeForwarders = ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, ilModule.GetRawTypeForwarders()) - XmlDocumentationInfo = - match tcConfig.xmlDocInfoLoader with - | Some xmlDocInfoLoader -> xmlDocInfoLoader.TryLoad(fileName) - | _ -> None + TryGetILModuleDef = ilModule.TryGetILModuleDef + UsesFSharp20PlusQuotations = minfo.usesQuotations + MemberSignatureEquality = (fun ty1 ty2 -> typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) + TypeForwarders = ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, ilModule.GetRawTypeForwarders()) + XmlDocumentationInfo = + match tcConfig.xmlDocInfoLoader with + | Some xmlDocInfoLoader -> xmlDocInfoLoader.TryLoad(fileName) + | _ -> None } let ccu = CcuThunk.Create(ccuName, ccuData) @@ -1568,182 +1982,223 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let optdata = lazy (match Map.tryFind ccuName optDatas with - | None -> - if verbose then dprintf "*** no optimization data for CCU %s, was DLL compiled with --no-optimization-data??\n" ccuName - None + | None -> None | Some info -> - let data = GetOptimizationData (fileName, ilScopeRef, ilModule.TryGetILModuleDef(), info) - let fixupThunk () = data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(ctok, m, nm, lookupOnly=false))) - - // Make a note of all ccuThunks that may still need to be fixed up when other dlls are loaded - tciLock.AcquireLock (fun tcitok -> - RequireTcImportsLock(tcitok, ccuThunks) - for ccuThunk in data.FixupThunks do - if ccuThunk.IsUnresolvedReference then - ccuThunks.Add(ccuThunk, fun () -> fixupThunk () |> ignore) - ) + let data = + GetOptimizationData(fileName, ilScopeRef, ilModule.TryGetILModuleDef(), info) - if verbose then dprintf "found optimization data for CCU %s\n" ccuName - Some (fixupThunk ())) + let fixupThunk () = + data.OptionalFixup(fun nm -> availableToOptionalCcu (tcImports.FindCcu(ctok, m, nm, lookupOnly = false))) + + // Make a note of all ccuThunks that may still need to be fixed up when other dlls are loaded + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, ccuThunks) + + for ccuThunk in data.FixupThunks do + if ccuThunk.IsUnresolvedReference then + ccuThunks.Add(ccuThunk, (fun () -> fixupThunk () |> ignore))) + + Some(fixupThunk ())) let ccuinfo = - { FSharpViewOfMetadata=ccu - AssemblyAutoOpenAttributes = ilModule.GetAutoOpenAttributes() - AssemblyInternalsVisibleToAttributes = ilModule.GetInternalsVisibleToAttributes() - FSharpOptimizationData=optdata + { + FSharpViewOfMetadata = ccu + AssemblyAutoOpenAttributes = ilModule.GetAutoOpenAttributes() + AssemblyInternalsVisibleToAttributes = ilModule.GetInternalsVisibleToAttributes() + FSharpOptimizationData = optdata #if !NO_TYPEPROVIDERS - IsProviderGenerated = false - TypeProviders = [] + IsProviderGenerated = false + TypeProviders = [] #endif - ILScopeRef = ilScopeRef } + ILScopeRef = ilScopeRef + } - let phase2() = + let phase2 () = #if !NO_TYPEPROVIDERS - match ilModule.TryGetILModuleDef() with - | None -> () // no type providers can be used without a real IL Module present - | Some ilModule -> - let tps = tcImports.ImportTypeProviderExtensions (ctok, tcConfig, fileName, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList(), ccu.Contents, invalidateCcu, m) - ccuinfo.TypeProviders <- tps + match ilModule.TryGetILModuleDef() with + | None -> () // no type providers can be used without a real IL Module present + | Some ilModule -> + let attrs = ilModule.ManifestOfAssembly.CustomAttrs.AsList() + + let tps = + tcImports.ImportTypeProviderExtensions( + ctok, + tcConfig, + fileName, + ilScopeRef, + attrs, + ccu.Contents, + invalidateCcu, + m + ) + + ccuinfo.TypeProviders <- tps #else - () + () #endif data, ccuinfo, phase2) // Register all before relinking to cope with mutually-referential ccus ccuRawDataAndInfos |> List.iter (p23 >> tcImports.RegisterCcu) + let phase2 () = // Relink ccuRawDataAndInfos |> List.iter (fun (data, _, _) -> - let fixupThunk () = data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(ctok, m, nm, lookupOnly=false))) |> ignore - fixupThunk() + let fixupThunk () = + data.OptionalFixup(fun nm -> availableToOptionalCcu (tcImports.FindCcu(ctok, m, nm, lookupOnly = false))) + |> ignore + + fixupThunk () + for ccuThunk in data.FixupThunks do if ccuThunk.IsUnresolvedReference then - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, ccuThunks) - ccuThunks.Add(ccuThunk, fixupThunk) - ) + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, ccuThunks) + ccuThunks.Add(ccuThunk, fixupThunk))) #if !NO_TYPEPROVIDERS - ccuRawDataAndInfos |> List.iter (fun (_, _, phase2) -> phase2()) + ccuRawDataAndInfos |> List.iter (fun (_, _, phase2) -> phase2 ()) #endif ccuRawDataAndInfos |> List.map p23 |> List.map ResolvedImportedAssembly + phase2 // NOTE: When used in the Language Service this can cause the transitive checking of projects. Hence it must be cancellable. - member tcImports.TryRegisterAndPrepareToImportReferencedDll (ctok, r: AssemblyResolution) : NodeCode<(_ * (unit -> AvailableImportedAssembly list)) option> = - node { - CheckDisposed() - let m = r.originalReference.Range - let fileName = r.resolvedPath - let! contentsOpt = - node { - match r.ProjectReference with - | Some ilb -> - return! ilb.EvaluateRawContents() - | None -> - return ProjectAssemblyDataResult.Unavailable true - } - - // If we have a project reference but did not get any valid contents, - // just return None and do not attempt to read elsewhere. - match contentsOpt with - | ProjectAssemblyDataResult.Unavailable false -> - return None - | _ -> - - let assemblyData = + member tcImports.TryRegisterAndPrepareToImportReferencedDll + ( + ctok, + r: AssemblyResolution + ) : NodeCode<(_ * (unit -> AvailableImportedAssembly list)) option> = + node { + CheckDisposed() + let m = r.originalReference.Range + let fileName = r.resolvedPath + + let! contentsOpt = + node { + match r.ProjectReference with + | Some ilb -> return! ilb.EvaluateRawContents() + | None -> return ProjectAssemblyDataResult.Unavailable true + } + + // If we have a project reference but did not get any valid contents, + // just return None and do not attempt to read elsewhere. match contentsOpt with - | ProjectAssemblyDataResult.Available ilb -> ilb - | ProjectAssemblyDataResult.Unavailable _ -> - let ilModule, ilAssemblyRefs = tcImports.OpenILBinaryModule(ctok, fileName, m) - RawFSharpAssemblyDataBackedByFileOnDisk (ilModule, ilAssemblyRefs) :> IRawFSharpAssemblyData - - let ilShortAssemName = assemblyData.ShortAssemblyName - let ilScopeRef = assemblyData.ILScopeRef - - if tcImports.IsAlreadyRegistered ilShortAssemName then - let dllinfo = tcImports.FindDllInfo(ctok, m, ilShortAssemName) - let phase2() = [tcImports.FindCcuInfo(ctok, m, ilShortAssemName, lookupOnly=true)] - return Some(dllinfo, phase2) - else - let dllinfo = - { RawMetadata=assemblyData - FileName=fileName + | ProjectAssemblyDataResult.Unavailable false -> return None + | _ -> + + let assemblyData = + match contentsOpt with + | ProjectAssemblyDataResult.Available ilb -> ilb + | ProjectAssemblyDataResult.Unavailable _ -> + let ilModule, ilAssemblyRefs = tcImports.OpenILBinaryModule(ctok, fileName, m) + RawFSharpAssemblyDataBackedByFileOnDisk(ilModule, ilAssemblyRefs) :> IRawFSharpAssemblyData + + let ilShortAssemName = assemblyData.ShortAssemblyName + let ilScopeRef = assemblyData.ILScopeRef + + if tcImports.IsAlreadyRegistered ilShortAssemName then + let dllinfo = tcImports.FindDllInfo(ctok, m, ilShortAssemName) + + let phase2 () = + [ tcImports.FindCcuInfo(ctok, m, ilShortAssemName, lookupOnly = true) ] + + return Some(dllinfo, phase2) + else + let dllinfo = + { + RawMetadata = assemblyData + FileName = fileName #if !NO_TYPEPROVIDERS - ProviderGeneratedAssembly=None - IsProviderGenerated=false - ProviderGeneratedStaticLinkMap = None + ProviderGeneratedAssembly = None + IsProviderGenerated = false + ProviderGeneratedStaticLinkMap = None #endif - ILScopeRef = ilScopeRef - ILAssemblyRefs = assemblyData.ILAssemblyRefs } - tcImports.RegisterDll dllinfo - let phase2 = - if assemblyData.HasAnyFSharpSignatureDataAttribute then - if not assemblyData.HasMatchingFSharpSignatureDataAttribute then - errorR(Error(FSComp.SR.buildDifferentVersionMustRecompile fileName, m)) - tcImports.PrepareToImportReferencedILAssembly (ctok, m, fileName, dllinfo) - else - try - tcImports.PrepareToImportReferencedFSharpAssembly (ctok, m, fileName, dllinfo) - with e -> error(Error(FSComp.SR.buildErrorOpeningBinaryFile(fileName, e.Message), m)) - else - tcImports.PrepareToImportReferencedILAssembly (ctok, m, fileName, dllinfo) - return Some(dllinfo, phase2) - } + ILScopeRef = ilScopeRef + ILAssemblyRefs = assemblyData.ILAssemblyRefs + } + + tcImports.RegisterDll dllinfo + + let phase2 = + if assemblyData.HasAnyFSharpSignatureDataAttribute then + if not assemblyData.HasMatchingFSharpSignatureDataAttribute then + errorR (Error(FSComp.SR.buildDifferentVersionMustRecompile fileName, m)) + tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo) + else + try + tcImports.PrepareToImportReferencedFSharpAssembly(ctok, m, fileName, dllinfo) + with e -> + error (Error(FSComp.SR.buildErrorOpeningBinaryFile (fileName, e.Message), m)) + else + tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo) - // NOTE: When used in the Language Service this can cause the transitive checking of projects. Hence it must be cancellable. - member tcImports.RegisterAndImportReferencedAssemblies (ctok, nms: AssemblyResolution list) = - node { - CheckDisposed() + return Some(dllinfo, phase2) + } - let! results = - nms - |> List.map (fun nm -> - node { - try - return! tcImports.TryRegisterAndPrepareToImportReferencedDll (ctok, nm) - with e -> - errorR(Error(FSComp.SR.buildProblemReadingAssembly(nm.resolvedPath, e.Message), nm.originalReference.Range)) - return None - } - ) - |> NodeCode.Sequential + // NOTE: When used in the Language Service this can cause the transitive checking of projects. Hence it must be cancellable. + member tcImports.RegisterAndImportReferencedAssemblies(ctok, nms: AssemblyResolution list) = + node { + CheckDisposed() - let dllinfos, phase2s = results |> Array.choose id |> List.ofArray |> List.unzip - fixupOrphanCcus() - let ccuinfos = (List.collect (fun phase2 -> phase2()) phase2s) - return dllinfos, ccuinfos - } + let! results = + nms + |> List.map (fun nm -> + node { + try + return! tcImports.TryRegisterAndPrepareToImportReferencedDll(ctok, nm) + with e -> + errorR (Error(FSComp.SR.buildProblemReadingAssembly (nm.resolvedPath, e.Message), nm.originalReference.Range)) + return None + }) + |> NodeCode.Sequential + + let dllinfos, phase2s = results |> Array.choose id |> List.ofArray |> List.unzip + fixupOrphanCcus () + let ccuinfos = (List.collect (fun phase2 -> phase2 ()) phase2s) + return dllinfos, ccuinfos + } /// Note that implicit loading is not used for compilations from MSBuild, which passes ``--noframework`` /// Implicit loading is done in non-cancellation mode. Implicit loading is never used in the language service, so /// no cancellation is needed. - member tcImports.ImplicitLoadIfAllowed (ctok, m, assemblyName, lookupOnly) = + member tcImports.ImplicitLoadIfAllowed(ctok, m, assemblyName, lookupOnly) = CheckDisposed() // If the user is asking for the default framework then also try to resolve other implicit assemblies as they are discovered. // Using this flag to mean 'allow implicit discover of assemblies'. let tcConfig = tcConfigP.Get ctok + if not lookupOnly && tcConfig.implicitlyResolveAssemblies then let tryFile speculativeFileName = - let foundFile = tcImports.TryResolveAssemblyReference (ctok, AssemblyReference (m, speculativeFileName, None), ResolveAssemblyReferenceMode.Speculative) + let foundFile = + tcImports.TryResolveAssemblyReference( + ctok, + AssemblyReference(m, speculativeFileName, None), + ResolveAssemblyReferenceMode.Speculative + ) + match foundFile with | OkResult (warns, res) -> ReportWarnings warns - tcImports.RegisterAndImportReferencedAssemblies(ctok, res) - |> NodeCode.RunImmediateWithoutCancellation + + tcImports.RegisterAndImportReferencedAssemblies(ctok, res) + |> NodeCode.RunImmediateWithoutCancellation |> ignore + true | ErrorResult (_warns, _err) -> // Throw away warnings and errors - this is speculative loading false - if tryFile (assemblyName + ".dll") then () - else tryFile (assemblyName + ".exe") |> ignore + if tryFile (assemblyName + ".dll") then + () + else + tryFile (assemblyName + ".exe") |> ignore #if !NO_TYPEPROVIDERS member tcImports.TryFindProviderGeneratedAssemblyByName(ctok, assemblyName: string) : System.Reflection.Assembly option = // The assembly may not be in the resolutions, but may be in the load set including EST injected assemblies - match tcImports.TryFindDllInfo (ctok, range0, assemblyName, lookupOnly=true) with + match tcImports.TryFindDllInfo(ctok, range0, assemblyName, lookupOnly = true) with | Some res -> // Provider-generated assemblies don't necessarily have an on-disk representation we can load. res.ProviderGeneratedAssembly @@ -1752,64 +2207,74 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse /// Only used by F# Interactive member tcImports.TryFindExistingFullyQualifiedPathBySimpleAssemblyName simpleAssemName : string option = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, resolutions) - resolutions.TryFindBySimpleAssemblyName simpleAssemName |> Option.map (fun r -> r.resolvedPath) + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, resolutions) + + resolutions.TryFindBySimpleAssemblyName simpleAssemName + |> Option.map (fun r -> r.resolvedPath)) /// Only used by F# Interactive member tcImports.TryFindExistingFullyQualifiedPathByExactAssemblyRef(assemblyRef: ILAssemblyRef) : string option = - tciLock.AcquireLock <| fun tcitok -> - RequireTcImportsLock(tcitok, resolutions) - resolutions.TryFindByExactILAssemblyRef assemblyRef |> Option.map (fun r -> r.resolvedPath) - - member tcImports.TryResolveAssemblyReference(ctok, assemblyReference: AssemblyReference, mode: ResolveAssemblyReferenceMode) : OperationResult = - tciLock.AcquireLock <| fun tcitok -> - let tcConfig = tcConfigP.Get ctok + tciLock.AcquireLock(fun tcitok -> + RequireTcImportsLock(tcitok, resolutions) + + resolutions.TryFindByExactILAssemblyRef assemblyRef + |> Option.map (fun r -> r.resolvedPath)) + + member tcImports.TryResolveAssemblyReference + ( + ctok, + assemblyReference: AssemblyReference, + mode: ResolveAssemblyReferenceMode + ) : OperationResult = + tciLock.AcquireLock(fun tcitok -> + let tcConfig = tcConfigP.Get ctok - RequireTcImportsLock(tcitok, resolutions) - // First try to lookup via the original reference text. - match resolutions.TryFindByOriginalReference assemblyReference with - | Some assemblyResolution -> - ResultD [assemblyResolution] - | None -> + RequireTcImportsLock(tcitok, resolutions) + // First try to lookup via the original reference text. + match resolutions.TryFindByOriginalReference assemblyReference with + | Some assemblyResolution -> ResultD [ assemblyResolution ] + | None -> #if NO_MSBUILD_REFERENCE_RESOLUTION - try - ResultD [tcConfig.ResolveLibWithDirectories assemblyReference] - with e -> - ErrorD e + try + ResultD [ tcConfig.ResolveLibWithDirectories assemblyReference ] + with e -> + ErrorD e #else - // Next try to lookup up by the exact full resolved path. - match resolutions.TryFindByResolvedPath assemblyReference.Text with - | Some assemblyResolution -> - ResultD [assemblyResolution] - | None -> - if tcConfigP.Get(ctok).useSimpleResolution then - let action = - match mode with - | ResolveAssemblyReferenceMode.ReportErrors -> CcuLoadFailureAction.RaiseError - | ResolveAssemblyReferenceMode.Speculative -> CcuLoadFailureAction.ReturnNone - match tcConfig.ResolveLibWithDirectories (action, assemblyReference) with - | Some resolved -> - resolutions <- resolutions.AddResolutionResults [resolved] - ResultD [resolved] - | None -> - ErrorD(AssemblyNotResolved(assemblyReference.Text, assemblyReference.Range)) - else - // This is a previously unencountered assembly. Resolve it and add it to the list. - // But don't cache resolution failures because the assembly may appear on the disk later. - let resolved, unresolved = TcConfig.TryResolveLibsUsingMSBuildRules(tcConfig, [ assemblyReference ], assemblyReference.Range, mode) - match resolved, unresolved with - | assemblyResolution :: _, _ -> - resolutions <- resolutions.AddResolutionResults resolved - ResultD [assemblyResolution] - | _, _ :: _ -> - resolutions <- resolutions.AddUnresolvedReferences unresolved - ErrorD(AssemblyNotResolved(assemblyReference.Text, assemblyReference.Range)) - | [], [] -> - // Note, if mode=ResolveAssemblyReferenceMode.Speculative and the resolution failed then TryResolveLibsUsingMSBuildRules returns - // the empty list and we convert the failure into an AssemblyNotResolved here. - ErrorD(AssemblyNotResolved(assemblyReference.Text, assemblyReference.Range)) + // Next try to lookup up by the exact full resolved path. + match resolutions.TryFindByResolvedPath assemblyReference.Text with + | Some assemblyResolution -> ResultD [ assemblyResolution ] + | None -> + if tcConfigP.Get(ctok).useSimpleResolution then + let action = + match mode with + | ResolveAssemblyReferenceMode.ReportErrors -> CcuLoadFailureAction.RaiseError + | ResolveAssemblyReferenceMode.Speculative -> CcuLoadFailureAction.ReturnNone + + match tcConfig.ResolveLibWithDirectories(action, assemblyReference) with + | Some resolved -> + resolutions <- resolutions.AddResolutionResults [ resolved ] + ResultD [ resolved ] + | None -> ErrorD(AssemblyNotResolved(assemblyReference.Text, assemblyReference.Range)) + else + // This is a previously unencountered assembly. Resolve it and add it to the list. + // But don't cache resolution failures because the assembly may appear on the disk later. + let resolved, unresolved = + TcConfig.TryResolveLibsUsingMSBuildRules(tcConfig, [ assemblyReference ], assemblyReference.Range, mode) + + match resolved, unresolved with + | assemblyResolution :: _, _ -> + resolutions <- resolutions.AddResolutionResults resolved + ResultD [ assemblyResolution ] + | _, _ :: _ -> + resolutions <- resolutions.AddUnresolvedReferences unresolved + ErrorD(AssemblyNotResolved(assemblyReference.Text, assemblyReference.Range)) + | [], [] -> + // Note, if mode=ResolveAssemblyReferenceMode.Speculative and the resolution failed then TryResolveLibsUsingMSBuildRules returns + // the empty list and we convert the failure into an AssemblyNotResolved here. + ErrorD(AssemblyNotResolved(assemblyReference.Text, assemblyReference.Range)) #endif + ) member tcImports.ResolveAssemblyReference(ctok, assemblyReference, mode) : AssemblyResolution list = CommitOperationResult(tcImports.TryResolveAssemblyReference(ctok, assemblyReference, mode)) @@ -1817,181 +2282,258 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse // Note: This returns a TcImports object. However, framework TcImports are not currently disposed. The only reason // we dispose TcImports is because we need to dispose type providers, and type providers are never included in the framework DLL set. // If a framework set ever includes type providers, you will not have to worry about explicitly calling Dispose as the Finalizer will handle it. - static member BuildFrameworkTcImports (tcConfigP: TcConfigProvider, frameworkDLLs, nonFrameworkDLLs) = - node { - let ctok = CompilationThreadToken() - let tcConfig = tcConfigP.Get ctok - let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig, frameworkDLLs, []) - let tcAltResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig, nonFrameworkDLLs, []) - - let frameworkTcImports = new TcImports(tcConfigP, tcResolutions, None, None) - - // Fetch the primaryAssembly from the referenced assemblies otherwise - let primaryAssemblyReference = - let path = frameworkDLLs |> List.tryFind(fun dll -> String.Compare(Path.GetFileNameWithoutExtension(dll.resolvedPath), tcConfig.primaryAssembly.Name, StringComparison.OrdinalIgnoreCase) = 0) - match path with - | Some p -> AssemblyReference(range0, p.resolvedPath, None) - | None -> tcConfig.PrimaryAssemblyDllReference() - - let primaryAssemblyResolution = frameworkTcImports.ResolveAssemblyReference(ctok, primaryAssemblyReference, ResolveAssemblyReferenceMode.ReportErrors) - let! primaryAssem = frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, primaryAssemblyResolution) - let primaryScopeRef = - match primaryAssem with - | _, [ResolvedImportedAssembly ccu] -> ccu.FSharpViewOfMetadata.ILScopeRef - | _ -> failwith "primaryScopeRef - unexpected" - - let primaryAssemblyResolvedPath = - match primaryAssemblyResolution with - | [primaryAssemblyResolution] -> primaryAssemblyResolution.resolvedPath - | _ -> failwith "primaryAssemblyResolvedPath - unexpected" - - let resolvedAssemblies = tcResolutions.GetAssemblyResolutions() - - let readerSettings: ILReaderOptions = - { pdbDirPath=None - reduceMemoryUsage = tcConfig.reduceMemoryUsage - metadataOnly = MetadataOnlyFlag.Yes - tryGetMetadataSnapshot = tcConfig.tryGetMetadataSnapshot } - - let tryFindAssemblyByExportedType manifest (exportedType: ILExportedTypeOrForwarder) = - match exportedType.ScopeRef, primaryScopeRef with - | ILScopeRef.Assembly aref1, ILScopeRef.Assembly aref2 when aref1.EqualsIgnoringVersion aref2 -> - mkRefToILAssembly manifest - |> Some - | _ -> - None + static member BuildFrameworkTcImports(tcConfigP: TcConfigProvider, frameworkDLLs, nonFrameworkDLLs) = + node { + let ctok = CompilationThreadToken() + let tcConfig = tcConfigP.Get ctok - let tryFindAssemblyThatForwardsToPrimaryAssembly manifest = - manifest.ExportedTypes.TryFindByName "System.Object" - |> Option.bind (tryFindAssemblyByExportedType manifest) - - // Determine what other assemblies could have been the primary assembly - // by checking to see if "System.Object" is an exported type. - let assembliesThatForwardToPrimaryAssembly = - resolvedAssemblies - |> List.choose (fun resolvedAssembly -> - if primaryAssemblyResolvedPath <> resolvedAssembly.resolvedPath then - let reader = OpenILModuleReader resolvedAssembly.resolvedPath readerSettings - reader.ILModuleDef.Manifest - |> Option.bind tryFindAssemblyThatForwardsToPrimaryAssembly - else - None) + let tcResolutions = + TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig, frameworkDLLs, []) - let! fslibCcu, fsharpCoreAssemblyScopeRef = - node { - if tcConfig.compilingFSharpCore then - // When compiling FSharp.Core.dll, the fslibCcu reference to FSharp.Core.dll is a delayed ccu thunk fixed up during type checking - return CcuThunk.CreateDelayed getFSharpCoreLibraryName, ILScopeRef.Local - else - let coreLibraryReference = tcConfig.CoreLibraryDllReference() + let tcAltResolutions = + TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig, nonFrameworkDLLs, []) - let resolvedAssemblyRef = - match tcResolutions.TryFindByOriginalReference coreLibraryReference with - | Some resolution -> Some resolution - | _ -> - // Are we using a "non-canonical" FSharp.Core? - match tcAltResolutions.TryFindByOriginalReference coreLibraryReference with - | Some resolution -> Some resolution - | _ -> tcResolutions.TryFindByOriginalReferenceText getFSharpCoreLibraryName // was the ".dll" elided? + let frameworkTcImports = new TcImports(tcConfigP, tcResolutions, None, None) - match resolvedAssemblyRef with - | Some coreLibraryResolution -> - match! frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, [coreLibraryResolution]) with - | _, [ResolvedImportedAssembly fslibCcuInfo ] -> return fslibCcuInfo.FSharpViewOfMetadata, fslibCcuInfo.ILScopeRef - | _ -> - return error(InternalError("BuildFrameworkTcImports: no successful import of "+coreLibraryResolution.resolvedPath, coreLibraryResolution.originalReference.Range)) - | None -> - return error(InternalError(sprintf "BuildFrameworkTcImports: no resolution of '%s'" coreLibraryReference.Text, rangeStartup)) - } + // Fetch the primaryAssembly from the referenced assemblies otherwise + let primaryAssemblyReference = + let path = + frameworkDLLs + |> List.tryFind (fun dll -> + let baseName = Path.GetFileNameWithoutExtension(dll.resolvedPath) - // Load the rest of the framework DLLs all at once (they may be mutually recursive) - let! _assemblies = frameworkTcImports.RegisterAndImportReferencedAssemblies (ctok, resolvedAssemblies) + let res = + String.Compare(baseName, tcConfig.primaryAssembly.Name, StringComparison.OrdinalIgnoreCase) - // These are the DLLs we can search for well-known types - let sysCcus = - [| for ccu in frameworkTcImports.GetCcusInDeclOrder() do - yield ccu |] + res = 0) - let tryFindSysTypeCcu path typeName = - sysCcus |> Array.tryFind (fun ccu -> ccuHasType ccu path typeName) + match path with + | Some p -> AssemblyReference(range0, p.resolvedPath, None) + | None -> tcConfig.PrimaryAssemblyDllReference() - let ilGlobals = mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) + let primaryAssemblyResolution = + frameworkTcImports.ResolveAssemblyReference(ctok, primaryAssemblyReference, ResolveAssemblyReferenceMode.ReportErrors) - // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals - let tcGlobals = - TcGlobals(tcConfig.compilingFSharpCore, - ilGlobals, - fslibCcu, - tcConfig.implicitIncludeDir, - tcConfig.mlCompatibility, - tcConfig.isInteractive, - tryFindSysTypeCcu, - tcConfig.emitDebugInfoInQuotations, - tcConfig.noDebugAttributes, - tcConfig.pathMap, - tcConfig.langVersion) + let! primaryAssem = frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, primaryAssemblyResolution) + + let primaryScopeRef = + match primaryAssem with + | _, [ ResolvedImportedAssembly ccu ] -> ccu.FSharpViewOfMetadata.ILScopeRef + | _ -> failwith "primaryScopeRef - unexpected" + + let primaryAssemblyResolvedPath = + match primaryAssemblyResolution with + | [ primaryAssemblyResolution ] -> primaryAssemblyResolution.resolvedPath + | _ -> failwith "primaryAssemblyResolvedPath - unexpected" + + let resolvedAssemblies = tcResolutions.GetAssemblyResolutions() + + let readerSettings: ILReaderOptions = + { + pdbDirPath = None + reduceMemoryUsage = tcConfig.reduceMemoryUsage + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = tcConfig.tryGetMetadataSnapshot + } + + let tryFindAssemblyByExportedType manifest (exportedType: ILExportedTypeOrForwarder) = + match exportedType.ScopeRef, primaryScopeRef with + | ILScopeRef.Assembly aref1, ILScopeRef.Assembly aref2 when aref1.EqualsIgnoringVersion aref2 -> + mkRefToILAssembly manifest |> Some + | _ -> None + + let tryFindAssemblyThatForwardsToPrimaryAssembly manifest = + manifest.ExportedTypes.TryFindByName "System.Object" + |> Option.bind (tryFindAssemblyByExportedType manifest) + + // Determine what other assemblies could have been the primary assembly + // by checking to see if "System.Object" is an exported type. + let assembliesThatForwardToPrimaryAssembly = + resolvedAssemblies + |> List.choose (fun resolvedAssembly -> + if primaryAssemblyResolvedPath <> resolvedAssembly.resolvedPath then + let reader = OpenILModuleReader resolvedAssembly.resolvedPath readerSettings + + reader.ILModuleDef.Manifest + |> Option.bind tryFindAssemblyThatForwardsToPrimaryAssembly + else + None) + + let! fslibCcu, fsharpCoreAssemblyScopeRef = + node { + if tcConfig.compilingFSharpCore then + // When compiling FSharp.Core.dll, the fslibCcu reference to FSharp.Core.dll is a delayed ccu thunk fixed up during type checking + return CcuThunk.CreateDelayed getFSharpCoreLibraryName, ILScopeRef.Local + else + let coreLibraryReference = tcConfig.CoreLibraryDllReference() + + let resolvedAssemblyRef = + match tcResolutions.TryFindByOriginalReference coreLibraryReference with + | Some resolution -> Some resolution + | _ -> + // Are we using a "non-canonical" FSharp.Core? + match tcAltResolutions.TryFindByOriginalReference coreLibraryReference with + | Some resolution -> Some resolution + | _ -> tcResolutions.TryFindByOriginalReferenceText getFSharpCoreLibraryName // was the ".dll" elided? + + match resolvedAssemblyRef with + | Some coreLibraryResolution -> + match! frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, [ coreLibraryResolution ]) with + | _, [ ResolvedImportedAssembly fslibCcuInfo ] -> + return fslibCcuInfo.FSharpViewOfMetadata, fslibCcuInfo.ILScopeRef + | _ -> + return + error ( + InternalError( + $"no import of {coreLibraryResolution.resolvedPath}", + coreLibraryResolution.originalReference.Range + ) + ) + | None -> return error (InternalError($"no resolution of '{coreLibraryReference.Text}'", rangeStartup)) + } + + // Load the rest of the framework DLLs all at once (they may be mutually recursive) + let! _assemblies = frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, resolvedAssemblies) + + // These are the DLLs we can search for well-known types + let sysCcus = + [| + for ccu in frameworkTcImports.GetCcusInDeclOrder() do + ccu + |] + + let tryFindSysTypeCcu path typeName = + sysCcus |> Array.tryFind (fun ccu -> ccuHasType ccu path typeName) + + let ilGlobals = + mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) + + // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals + let tcGlobals = + TcGlobals( + tcConfig.compilingFSharpCore, + ilGlobals, + fslibCcu, + tcConfig.implicitIncludeDir, + tcConfig.mlCompatibility, + tcConfig.isInteractive, + tryFindSysTypeCcu, + tcConfig.emitDebugInfoInQuotations, + tcConfig.noDebugAttributes, + tcConfig.pathMap, + tcConfig.langVersion + ) #if DEBUG - // the global_g reference cell is used only for debug printing - global_g <- Some tcGlobals + // the global_g reference cell is used only for debug printing + global_g <- Some tcGlobals #endif - frameworkTcImports.SetTcGlobals tcGlobals - return tcGlobals, frameworkTcImports - } + frameworkTcImports.SetTcGlobals tcGlobals + return tcGlobals, frameworkTcImports + } member tcImports.ReportUnresolvedAssemblyReferences knownUnresolved = // Report that an assembly was not resolved. - let reportAssemblyNotResolved(file, originalReferences: AssemblyReference list) = - originalReferences |> List.iter(fun originalReference -> errorR(AssemblyNotResolved(file, originalReference.Range))) + let reportAssemblyNotResolved (file, originalReferences: AssemblyReference list) = + originalReferences + |> List.iter (fun originalReference -> errorR (AssemblyNotResolved(file, originalReference.Range))) + knownUnresolved - |> List.map (function UnresolvedAssemblyReference(file, originalReferences) -> file, originalReferences) + |> List.map (function + | UnresolvedAssemblyReference (file, originalReferences) -> file, originalReferences) |> List.iter reportAssemblyNotResolved static member BuildNonFrameworkTcImports - (tcConfigP: TcConfigProvider, baseTcImports, - nonFrameworkReferences, knownUnresolved, dependencyProvider) = + ( + tcConfigP: TcConfigProvider, + baseTcImports, + nonFrameworkReferences, + knownUnresolved, + dependencyProvider + ) = + + node { + let ctok = CompilationThreadToken() + let tcConfig = tcConfigP.Get ctok - node { - let ctok = CompilationThreadToken() - let tcConfig = tcConfigP.Get ctok - let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig, nonFrameworkReferences, knownUnresolved) - let references = tcResolutions.GetAssemblyResolutions() - let tcImports = new TcImports(tcConfigP, tcResolutions, Some baseTcImports, Some dependencyProvider) - let! _assemblies = tcImports.RegisterAndImportReferencedAssemblies(ctok, references) - tcImports.ReportUnresolvedAssemblyReferences knownUnresolved - return tcImports - } + let tcResolutions = + TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig, nonFrameworkReferences, knownUnresolved) + + let references = tcResolutions.GetAssemblyResolutions() + + let tcImports = + new TcImports(tcConfigP, tcResolutions, Some baseTcImports, Some dependencyProvider) + + let! _assemblies = tcImports.RegisterAndImportReferencedAssemblies(ctok, references) + tcImports.ReportUnresolvedAssemblyReferences knownUnresolved + return tcImports + } static member BuildTcImports(tcConfigP: TcConfigProvider, dependencyProvider) = - node { - let ctok = CompilationThreadToken() - let tcConfig = tcConfigP.Get ctok - let frameworkDLLs, nonFrameworkReferences, knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) - let! tcGlobals, frameworkTcImports = TcImports.BuildFrameworkTcImports (tcConfigP, frameworkDLLs, nonFrameworkReferences) - let! tcImports = TcImports.BuildNonFrameworkTcImports(tcConfigP, frameworkTcImports, nonFrameworkReferences, knownUnresolved, dependencyProvider) - return tcGlobals, tcImports - } + node { + let ctok = CompilationThreadToken() + let tcConfig = tcConfigP.Get ctok + + let frameworkDLLs, nonFrameworkReferences, knownUnresolved = + TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) + + let! tcGlobals, frameworkTcImports = TcImports.BuildFrameworkTcImports(tcConfigP, frameworkDLLs, nonFrameworkReferences) + + let! tcImports = + TcImports.BuildNonFrameworkTcImports( + tcConfigP, + frameworkTcImports, + nonFrameworkReferences, + knownUnresolved, + dependencyProvider + ) + + return tcGlobals, tcImports + } interface IDisposable with - member tcImports.Dispose() = - dispose () + member tcImports.Dispose() = dispose () override tcImports.ToString() = "TcImports(...)" /// Process #r in F# Interactive. /// Adds the reference to the tcImports and add the ccu to the type checking environment. let RequireDLL (ctok, tcImports: TcImports, tcEnv, thisAssemblyName, referenceRange, file) = - let resolutions = CommitOperationResult(tcImports.TryResolveAssemblyReference(ctok, AssemblyReference(referenceRange, file, None), ResolveAssemblyReferenceMode.ReportErrors)) - let dllinfos, ccuinfos = - tcImports.RegisterAndImportReferencedAssemblies(ctok, resolutions) + let resolutions = + CommitOperationResult( + tcImports.TryResolveAssemblyReference( + ctok, + AssemblyReference(referenceRange, file, None), + ResolveAssemblyReferenceMode.ReportErrors + ) + ) + + let dllinfos, ccuinfos = + tcImports.RegisterAndImportReferencedAssemblies(ctok, resolutions) |> NodeCode.RunImmediateWithoutCancellation let asms = - ccuinfos |> List.map (function + ccuinfos + |> List.map (function | ResolvedImportedAssembly asm -> asm - | UnresolvedImportedAssembly assemblyName -> error(Error(FSComp.SR.buildCouldNotResolveAssemblyRequiredByFile(assemblyName, file), referenceRange))) + | UnresolvedImportedAssembly assemblyName -> + error (Error(FSComp.SR.buildCouldNotResolveAssemblyRequiredByFile (assemblyName, file), referenceRange))) let g = tcImports.GetTcGlobals() let amap = tcImports.GetImportMap() - let _openDecls, tcEnv = (tcEnv, asms) ||> List.collectFold (fun tcEnv asm -> AddCcuToTcEnv(g, amap, referenceRange, tcEnv, thisAssemblyName, asm.FSharpViewOfMetadata, asm.AssemblyAutoOpenAttributes, asm.AssemblyInternalsVisibleToAttributes)) + + let _openDecls, tcEnv = + (tcEnv, asms) + ||> List.collectFold (fun tcEnv asm -> + AddCcuToTcEnv( + g, + amap, + referenceRange, + tcEnv, + thisAssemblyName, + asm.FSharpViewOfMetadata, + asm.AssemblyAutoOpenAttributes, + asm.AssemblyInternalsVisibleToAttributes + )) + tcEnv, (dllinfos, asms) diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 1d211eee26a..b46754e88be 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -28,7 +28,7 @@ module Attributes = //[] [] - do() + do () //---------------------------------------------------------------------------- // Compiler option parser @@ -59,11 +59,20 @@ type OptionSpec = | OptionStringList of (string -> unit) | OptionStringListSwitch of (string -> OptionSwitch -> unit) | OptionUnit of (unit -> unit) - | OptionHelp of (CompilerOptionBlock list -> unit) // like OptionUnit, but given the "options" + | OptionHelp of (CompilerOptionBlock list -> unit) // like OptionUnit, but given the "options" | OptionGeneral of (string list -> bool) * (string list -> string list) // Applies? * (ApplyReturningResidualArgs) -and CompilerOption = CompilerOption of name: string * argumentDescriptionString: string * actionSpec: OptionSpec * deprecationError: Option * helpText: string option -and CompilerOptionBlock = PublicOptions of heading: string * options: CompilerOption list | PrivateOptions of options: CompilerOption list +and CompilerOption = + | CompilerOption of + name: string * + argumentDescriptionString: string * + actionSpec: OptionSpec * + deprecationError: Option * + helpText: string option + +and CompilerOptionBlock = + | PublicOptions of heading: string * options: CompilerOption list + | PrivateOptions of options: CompilerOption list let GetOptionsOfBlock block = match block with @@ -72,13 +81,21 @@ let GetOptionsOfBlock block = let FilterCompilerOptionBlock pred block = match block with - | PublicOptions(heading, opts) -> PublicOptions(heading, List.filter pred opts) - | PrivateOptions opts -> PrivateOptions(List.filter pred opts) + | PublicOptions (heading, opts) -> PublicOptions(heading, List.filter pred opts) + | PrivateOptions opts -> PrivateOptions(List.filter pred opts) + +let compilerOptionUsage (CompilerOption (s, tag, spec, _, _)) = + let s = + if s = "--" then + "" + else + s (* s="flag" for "--flag" options. s="--" for "--" option. Adjust printing here for "--" case. *) -let compilerOptionUsage (CompilerOption(s, tag, spec, _, _)) = - let s = if s="--" then "" else s (* s="flag" for "--flag" options. s="--" for "--" option. Adjust printing here for "--" case. *) match spec with - | OptionUnit _ | OptionSet _ | OptionClear _ | OptionHelp _ -> sprintf "--%s" s + | OptionUnit _ + | OptionSet _ + | OptionClear _ + | OptionHelp _ -> sprintf "--%s" s | OptionStringList _ -> sprintf "--%s:%s" s tag | OptionIntList _ -> sprintf "--%s:%s" s tag | OptionSwitch _ -> sprintf "--%s[+|-]" s @@ -86,285 +103,378 @@ let compilerOptionUsage (CompilerOption(s, tag, spec, _, _)) = | OptionIntListSwitch _ -> sprintf "--%s[+|-]:%s" s tag | OptionString _ -> sprintf "--%s:%s" s tag | OptionInt _ -> sprintf "--%s:%s" s tag - | OptionFloat _ -> sprintf "--%s:%s" s tag + | OptionFloat _ -> sprintf "--%s:%s" s tag | OptionRest _ -> sprintf "--%s ..." s - | OptionGeneral _ -> if tag="" then sprintf "%s" s else sprintf "%s:%s" s tag (* still being decided *) + | OptionGeneral _ -> + if tag = "" then + sprintf "%s" s + else + sprintf "%s:%s" s tag (* still being decided *) -let PrintCompilerOption (CompilerOption(_s, _tag, _spec, _, help) as compilerOption) = +let PrintCompilerOption (CompilerOption (_s, _tag, _spec, _, help) as compilerOption) = let flagWidth = 42 // fixed width for printing of flags, e.g. --debug:{full|pdbonly|portable|embedded} let defaultLineWidth = 80 // the fallback width + let lineWidth = try Console.BufferWidth - with e -> defaultLineWidth - let lineWidth = if lineWidth=0 then defaultLineWidth else lineWidth (* Have seen BufferWidth=0 on Linux/Mono *) + with e -> + defaultLineWidth + + let lineWidth = + if lineWidth = 0 then + defaultLineWidth + else + lineWidth (* Have seen BufferWidth=0 on Linux/Mono *) // Lines have this form: // flagWidth chars - for flags description or padding on continuation lines. // single space - space. // description - words upto but excluding the final character of the line. printf "%-40s" (compilerOptionUsage compilerOption) - let printWord column (word:string) = + + let printWord column (word: string) = // Have printed upto column. // Now print the next word including any preceding whitespace. // Returns the column printed to (suited to folding). if column + 1 (*space*) + word.Length >= lineWidth then // NOTE: "equality" ensures final character of the line is never printed - printfn "" (* newline *) - printf "%-40s %s" ""(*<--flags*) word - flagWidth + 1 + word.Length + printfn "" (* newline *) + printf "%-40s %s" "" (*<--flags*) word + flagWidth + 1 + word.Length else - printf " %s" word - column + 1 + word.Length - let words = match help with None -> [| |] | Some s -> s.Split [| ' ' |] + printf " %s" word + column + 1 + word.Length + + let words = + match help with + | None -> [||] + | Some s -> s.Split [| ' ' |] + let _finalColumn = Array.fold printWord flagWidth words printfn "" (* newline *) let PrintPublicOptions (heading, opts) = - if not (isNil opts) then - printfn "" - printfn "" - printfn "\t\t%s" heading - List.iter PrintCompilerOption opts + if not (isNil opts) then + printfn "" + printfn "" + printfn "\t\t%s" heading + List.iter PrintCompilerOption opts let PrintCompilerOptionBlocks blocks = - let equals x y = x=y - let publicBlocks = List.choose (function PrivateOptions _ -> None | PublicOptions (heading, opts) -> Some (heading, opts)) blocks - let consider doneHeadings (heading, _opts) = - if Set.contains heading doneHeadings then - doneHeadings - else - let headingOptions = List.filter (fst >> equals heading) publicBlocks |> List.collect snd - PrintPublicOptions (heading, headingOptions) - Set.add heading doneHeadings - List.fold consider Set.empty publicBlocks |> ignore> + let publicBlocks = + blocks + |> List.choose (function + | PrivateOptions _ -> None + | PublicOptions (heading, opts) -> Some(heading, opts)) + + let consider doneHeadings (heading, _opts) = + if Set.contains heading doneHeadings then + doneHeadings + else + let headingOptions = + publicBlocks |> List.filter (fun (h2, _) -> heading = h2) |> List.collect snd + + PrintPublicOptions(heading, headingOptions) + Set.add heading doneHeadings + + List.fold consider Set.empty publicBlocks |> ignore> (* For QA *) -let dumpCompilerOption prefix (CompilerOption(str, _, spec, _, _)) = +let dumpCompilerOption prefix (CompilerOption (str, _, spec, _, _)) = printf "section='%-25s' ! option=%-30s kind=" prefix str + match spec with - | OptionUnit _ -> printf "OptionUnit" - | OptionSet _ -> printf "OptionSet" - | OptionClear _ -> printf "OptionClear" - | OptionHelp _ -> printf "OptionHelp" - | OptionStringList _ -> printf "OptionStringList" - | OptionIntList _ -> printf "OptionIntList" - | OptionSwitch _ -> printf "OptionSwitch" - | OptionStringListSwitch _ -> printf "OptionStringListSwitch" - | OptionIntListSwitch _ -> printf "OptionIntListSwitch" - | OptionString _ -> printf "OptionString" - | OptionInt _ -> printf "OptionInt" - | OptionFloat _ -> printf "OptionFloat" - | OptionRest _ -> printf "OptionRest" - | OptionGeneral _ -> printf "OptionGeneral" + | OptionUnit _ -> printf "OptionUnit" + | OptionSet _ -> printf "OptionSet" + | OptionClear _ -> printf "OptionClear" + | OptionHelp _ -> printf "OptionHelp" + | OptionStringList _ -> printf "OptionStringList" + | OptionIntList _ -> printf "OptionIntList" + | OptionSwitch _ -> printf "OptionSwitch" + | OptionStringListSwitch _ -> printf "OptionStringListSwitch" + | OptionIntListSwitch _ -> printf "OptionIntListSwitch" + | OptionString _ -> printf "OptionString" + | OptionInt _ -> printf "OptionInt" + | OptionFloat _ -> printf "OptionFloat" + | OptionRest _ -> printf "OptionRest" + | OptionGeneral _ -> printf "OptionGeneral" + printf "\n" -let dumpCompilerOptionBlock = function - | PublicOptions (heading, opts) -> List.iter (dumpCompilerOption heading) opts - | PrivateOptions opts -> List.iter (dumpCompilerOption "NoSection") opts -let DumpCompilerOptionBlocks blocks = List.iter dumpCompilerOptionBlock blocks -let isSlashOpt (opt:string) = - opt[0] = '/' && (opt.Length = 1 || not (opt[1..].Contains "/")) +let dumpCompilerOptionBlock = + function + | PublicOptions (heading, opts) -> List.iter (dumpCompilerOption heading) opts + | PrivateOptions opts -> List.iter (dumpCompilerOption "NoSection") opts + +let DumpCompilerOptionBlocks blocks = + List.iter dumpCompilerOptionBlock blocks + +let isSlashOpt (opt: string) = + opt[0] = '/' && (opt.Length = 1 || not (opt[ 1.. ].Contains "/")) module ResponseFile = type ResponseFileData = ResponseFileLine list + and ResponseFileLine = | CompilerOptionSpec of string | Comment of string - let parseFile path: Choice = + let parseFile path : Choice = let parseLine (l: string) = match l with | s when String.IsNullOrWhiteSpace s -> None - | s when l.StartsWithOrdinal("#") -> Some (ResponseFileLine.Comment (s.TrimStart('#'))) - | s -> Some (ResponseFileLine.CompilerOptionSpec (s.Trim())) + | s when l.StartsWithOrdinal("#") -> Some(ResponseFileLine.Comment(s.TrimStart('#'))) + | s -> Some(ResponseFileLine.CompilerOptionSpec(s.Trim())) try use stream = FileSystem.OpenFileForReadShim(path) use reader = new StreamReader(stream, true) + let data = - seq { while not reader.EndOfStream do yield reader.ReadLine () } + seq { + while not reader.EndOfStream do + reader.ReadLine() + } |> Seq.choose parseLine |> List.ofSeq + Choice1Of2 data with e -> Choice2Of2 e let ParseCompilerOptions (collectOtherArgument: string -> unit, blocks: CompilerOptionBlock list, args) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter + + let specs = List.collect GetOptionsOfBlock blocks + + // returns a tuple - the option token, the option argument string + let parseOption (s: string) = + // grab the option token + let opts = s.Split([| ':' |]) + let mutable opt = opts[0] + + if opt = "" then + () + // if it doesn't start with a '-' or '/', reject outright + elif opt[0] <> '-' && opt[0] <> '/' then + opt <- "" + elif opt <> "--" then + // is it an abbreviated or MSFT-style option? + // if so, strip the first character and move on with your life + if opt.Length = 2 || isSlashOpt opt then + opt <- opt[1..] + // else, it should be a non-abbreviated option starting with "--" + elif opt.Length > 3 && opt.StartsWithOrdinal("--") then + opt <- opt[2..] + else + opt <- "" + + // get the argument string + let optArgs = if opts.Length > 1 then String.Join(":", opts[1..]) else "" + opt, optArgs + + let getOptionArg compilerOption (argString: string) = + if argString = "" then + errorR (Error(FSComp.SR.buildOptionRequiresParameter (compilerOptionUsage compilerOption), rangeCmdArgs)) + + argString + + let getOptionArgList compilerOption (argString: string) = + if argString = "" then + errorR (Error(FSComp.SR.buildOptionRequiresParameter (compilerOptionUsage compilerOption), rangeCmdArgs)) + [] + else + argString.Split([| ','; ';' |]) |> List.ofArray + + let getSwitchOpt (opt: string) = + // if opt is a switch, strip the '+' or '-' + if opt <> "--" + && opt.Length > 1 + && (opt.EndsWithOrdinal("+") || opt.EndsWithOrdinal("-")) then + opt[0 .. opt.Length - 2] + else + opt - let specs = List.collect GetOptionsOfBlock blocks + let getSwitch (s: string) = + let s = (s.Split([| ':' |]))[0] - // returns a tuple - the option token, the option argument string - let parseOption (s: string) = - // grab the option token - let opts = s.Split([|':'|]) - let mutable opt = opts[0] - if opt = "" then - () - // if it doesn't start with a '-' or '/', reject outright - elif opt[0] <> '-' && opt[0] <> '/' then - opt <- "" - elif opt <> "--" then - // is it an abbreviated or MSFT-style option? - // if so, strip the first character and move on with your life - if opt.Length = 2 || isSlashOpt opt then - opt <- opt[1 ..] - // else, it should be a non-abbreviated option starting with "--" - elif opt.Length > 3 && opt.StartsWithOrdinal("--") then - opt <- opt[2 ..] - else - opt <- "" - - // get the argument string - let optArgs = if opts.Length > 1 then String.Join(":", opts[1 ..]) else "" - opt, optArgs - - let getOptionArg compilerOption (argString: string) = - if argString = "" then - errorR(Error(FSComp.SR.buildOptionRequiresParameter(compilerOptionUsage compilerOption), rangeCmdArgs)) - argString - - let getOptionArgList compilerOption (argString: string) = - if argString = "" then - errorR(Error(FSComp.SR.buildOptionRequiresParameter(compilerOptionUsage compilerOption), rangeCmdArgs)) - [] - else - argString.Split([|',';';'|]) |> List.ofArray + if s <> "--" && s.EndsWithOrdinal("-") then + OptionSwitch.Off + else + OptionSwitch.On + + let rec processArg args = + match args with + | [] -> () + | rsp: string :: t when rsp.StartsWithOrdinal("@") -> + let responseFileOptions = + let fullpath = + try + Some(rsp.TrimStart('@') |> FileSystem.GetFullPathShim) + with _ -> + None - let getSwitchOpt (opt: string) = - // if opt is a switch, strip the '+' or '-' - if opt <> "--" && opt.Length > 1 && (opt.EndsWithOrdinal("+") || opt.EndsWithOrdinal("-")) then - opt[0 .. opt.Length - 2] - else - opt - - let getSwitch (s: string) = - let s = (s.Split([|':'|]))[0] - if s <> "--" && s.EndsWithOrdinal("-") then OptionSwitch.Off else OptionSwitch.On - - let rec processArg args = - match args with - | [] -> () - | rsp: string :: t when rsp.StartsWithOrdinal("@") -> - let responseFileOptions = - let fullpath = - try - Some (rsp.TrimStart('@') |> FileSystem.GetFullPathShim) - with _ -> - None - - match fullpath with - | None -> - errorR(Error(FSComp.SR.optsResponseFileNameInvalid rsp, rangeCmdArgs)) - [] - | Some path when not (FileSystem.FileExistsShim path) -> - errorR(Error(FSComp.SR.optsResponseFileNotFound(rsp, path), rangeCmdArgs)) - [] - | Some path -> - match ResponseFile.parseFile path with - | Choice2Of2 _ -> - errorR(Error(FSComp.SR.optsInvalidResponseFile(rsp, path), rangeCmdArgs)) + match fullpath with + | None -> + errorR (Error(FSComp.SR.optsResponseFileNameInvalid rsp, rangeCmdArgs)) + [] + | Some path when not (FileSystem.FileExistsShim path) -> + errorR (Error(FSComp.SR.optsResponseFileNotFound (rsp, path), rangeCmdArgs)) + [] + | Some path -> + match ResponseFile.parseFile path with + | Choice2Of2 _ -> + errorR (Error(FSComp.SR.optsInvalidResponseFile (rsp, path), rangeCmdArgs)) + [] + | Choice1Of2 rspData -> + let onlyOptions l = + match l with + | ResponseFile.ResponseFileLine.Comment _ -> None + | ResponseFile.ResponseFileLine.CompilerOptionSpec opt -> Some opt + + rspData |> List.choose onlyOptions + + processArg (responseFileOptions @ t) + | opt :: t -> + let optToken, argString = parseOption opt + + let reportDeprecatedOption errOpt = + match errOpt with + | Some e -> warning e + | None -> () + + let rec attempt l = + match l with + | CompilerOption (s, _, OptionHelp f, d, _) :: _ when optToken = s && argString = "" -> + reportDeprecatedOption d + f blocks + t + | CompilerOption (s, _, OptionUnit f, d, _) :: _ when optToken = s && argString = "" -> + reportDeprecatedOption d + f () + t + | CompilerOption (s, _, OptionSwitch f, d, _) :: _ when getSwitchOpt optToken = s && argString = "" -> + reportDeprecatedOption d + f (getSwitch opt) + t + | CompilerOption (s, _, OptionSet f, d, _) :: _ when optToken = s && argString = "" -> + reportDeprecatedOption d + f.Value <- true + t + | CompilerOption (s, _, OptionClear f, d, _) :: _ when optToken = s && argString = "" -> + reportDeprecatedOption d + f.Value <- false + t + | CompilerOption (s, _, OptionString f, d, _) as compilerOption :: _ when optToken = s -> + reportDeprecatedOption d + let oa = getOptionArg compilerOption argString + if oa <> "" then f (getOptionArg compilerOption oa) + t + | CompilerOption (s, _, OptionInt f, d, _) as compilerOption :: _ when optToken = s -> + reportDeprecatedOption d + let oa = getOptionArg compilerOption argString + + if oa <> "" then + f ( + try + int32 oa + with _ -> + errorR (Error(FSComp.SR.buildArgInvalidInt (getOptionArg compilerOption argString), rangeCmdArgs)) + 0 + ) + + t + | CompilerOption (s, _, OptionFloat f, d, _) as compilerOption :: _ when optToken = s -> + reportDeprecatedOption d + let oa = getOptionArg compilerOption argString + + if oa <> "" then + f ( + try + float oa + with _ -> + errorR (Error(FSComp.SR.buildArgInvalidFloat (getOptionArg compilerOption argString), rangeCmdArgs)) + 0.0 + ) + + t + | CompilerOption (s, _, OptionRest f, d, _) :: _ when optToken = s -> + reportDeprecatedOption d + List.iter f t [] - | Choice1Of2 rspData -> - let onlyOptions l = - match l with - | ResponseFile.ResponseFileLine.Comment _ -> None - | ResponseFile.ResponseFileLine.CompilerOptionSpec opt -> Some opt - rspData |> List.choose onlyOptions - - processArg (responseFileOptions @ t) - | opt :: t -> - let optToken, argString = parseOption opt - - let reportDeprecatedOption errOpt = - match errOpt with - | Some e -> warning e - | None -> () - - let rec attempt l = - match l with - | CompilerOption(s, _, OptionHelp f, d, _) :: _ when optToken = s && argString = "" -> - reportDeprecatedOption d - f blocks; t - | CompilerOption(s, _, OptionUnit f, d, _) :: _ when optToken = s && argString = "" -> - reportDeprecatedOption d - f (); t - | CompilerOption(s, _, OptionSwitch f, d, _) :: _ when getSwitchOpt optToken = s && argString = "" -> - reportDeprecatedOption d - f (getSwitch opt); t - | CompilerOption(s, _, OptionSet f, d, _) :: _ when optToken = s && argString = "" -> - reportDeprecatedOption d - f.Value <- true; t - | CompilerOption(s, _, OptionClear f, d, _) :: _ when optToken = s && argString = "" -> - reportDeprecatedOption d - f.Value <- false; t - | CompilerOption(s, _, OptionString f, d, _) as compilerOption :: _ when optToken = s -> - reportDeprecatedOption d - let oa = getOptionArg compilerOption argString - if oa <> "" then - f (getOptionArg compilerOption oa) - t - | CompilerOption(s, _, OptionInt f, d, _) as compilerOption :: _ when optToken = s -> - reportDeprecatedOption d - let oa = getOptionArg compilerOption argString - if oa <> "" then - f (try int32 oa with _ -> - errorR(Error(FSComp.SR.buildArgInvalidInt(getOptionArg compilerOption argString), rangeCmdArgs)); 0) - t - | CompilerOption(s, _, OptionFloat f, d, _) as compilerOption :: _ when optToken = s -> - reportDeprecatedOption d - let oa = getOptionArg compilerOption argString - if oa <> "" then - f (try float oa with _ -> - errorR(Error(FSComp.SR.buildArgInvalidFloat(getOptionArg compilerOption argString), rangeCmdArgs)); 0.0) - t - | CompilerOption(s, _, OptionRest f, d, _) :: _ when optToken = s -> - reportDeprecatedOption d - List.iter f t; [] - | CompilerOption(s, _, OptionIntList f, d, _) as compilerOption :: _ when optToken = s -> - reportDeprecatedOption d - let al = getOptionArgList compilerOption argString - if al <> [] then - List.iter (fun i -> f (try int32 i with _ -> errorR(Error(FSComp.SR.buildArgInvalidInt i, rangeCmdArgs)); 0)) al - t - | CompilerOption(s, _, OptionIntListSwitch f, d, _) as compilerOption :: _ when getSwitchOpt optToken = s -> - reportDeprecatedOption d - let al = getOptionArgList compilerOption argString - if al <> [] then - let switch = getSwitch opt - List.iter (fun i -> f (try int32 i with _ -> errorR(Error(FSComp.SR.buildArgInvalidInt i, rangeCmdArgs)); 0) switch) al - t - // here - | CompilerOption(s, _, OptionStringList f, d, _) as compilerOption :: _ when optToken = s -> - reportDeprecatedOption d - let al = getOptionArgList compilerOption argString - if al <> [] then - List.iter f (getOptionArgList compilerOption argString) - t - | CompilerOption(s, _, OptionStringListSwitch f, d, _) as compilerOption :: _ when getSwitchOpt optToken = s -> - reportDeprecatedOption d - let al = getOptionArgList compilerOption argString - if al <> [] then - let switch = getSwitch opt - List.iter (fun s -> f s switch) (getOptionArgList compilerOption argString) - t - | CompilerOption(_, _, OptionGeneral (pred, exec), d, _) :: _ when pred args -> - reportDeprecatedOption d - let rest = exec args in rest // arguments taken, rest remaining - | _ :: more -> attempt more - | [] -> - if opt.Length = 0 || opt[0] = '-' || isSlashOpt opt - then - // want the whole opt token - delimiter and all - let unrecOpt = opt.Split([|':'|]).[0] - errorR(Error(FSComp.SR.buildUnrecognizedOption unrecOpt, rangeCmdArgs)) - t - else - (collectOtherArgument opt; t) - let rest = attempt specs - processArg rest - - processArg args + | CompilerOption (s, _, OptionIntList f, d, _) as compilerOption :: _ when optToken = s -> + reportDeprecatedOption d + let al = getOptionArgList compilerOption argString + + if al <> [] then + List.iter + (fun i -> + f ( + try + int32 i + with _ -> + errorR (Error(FSComp.SR.buildArgInvalidInt i, rangeCmdArgs)) + 0 + )) + al + + t + | CompilerOption (s, _, OptionIntListSwitch f, d, _) as compilerOption :: _ when getSwitchOpt optToken = s -> + reportDeprecatedOption d + let al = getOptionArgList compilerOption argString + + if al <> [] then + let switch = getSwitch opt + + List.iter + (fun i -> + f + (try + int32 i + with _ -> + errorR (Error(FSComp.SR.buildArgInvalidInt i, rangeCmdArgs)) + 0) + switch) + al + + t + // here + | CompilerOption (s, _, OptionStringList f, d, _) as compilerOption :: _ when optToken = s -> + reportDeprecatedOption d + let al = getOptionArgList compilerOption argString + + if al <> [] then + List.iter f (getOptionArgList compilerOption argString) + + t + | CompilerOption (s, _, OptionStringListSwitch f, d, _) as compilerOption :: _ when getSwitchOpt optToken = s -> + reportDeprecatedOption d + let al = getOptionArgList compilerOption argString + + if al <> [] then + let switch = getSwitch opt + List.iter (fun s -> f s switch) (getOptionArgList compilerOption argString) + + t + | CompilerOption (_, _, OptionGeneral (pred, exec), d, _) :: _ when pred args -> + reportDeprecatedOption d + let rest = exec args in + rest // arguments taken, rest remaining + | _ :: more -> attempt more + | [] -> + if opt.Length = 0 || opt[0] = '-' || isSlashOpt opt then + // want the whole opt token - delimiter and all + let unrecOpt = opt.Split([| ':' |]).[0] + errorR (Error(FSComp.SR.buildUnrecognizedOption unrecOpt, rangeCmdArgs)) + t + else + (collectOtherArgument opt + t) + + let rest = attempt specs + processArg rest + + processArg args //---------------------------------------------------------------------------- // Compiler options @@ -379,26 +489,61 @@ let setFlag r n = | 1 -> r true | _ -> raise (Failure "expected 0/1") -let SetOptimizeOff(tcConfigB: TcConfigBuilder) = - tcConfigB.optSettings <- { tcConfigB.optSettings with jitOptUser = Some false } - tcConfigB.optSettings <- { tcConfigB.optSettings with localOptUser = Some false } - tcConfigB.optSettings <- { tcConfigB.optSettings with crossAssemblyOptimizationUser = Some false } - tcConfigB.optSettings <- { tcConfigB.optSettings with lambdaInlineThreshold = 0 } +let SetOptimizeOff (tcConfigB: TcConfigBuilder) = + tcConfigB.optSettings <- + { tcConfigB.optSettings with + jitOptUser = Some false + } + + tcConfigB.optSettings <- + { tcConfigB.optSettings with + localOptUser = Some false + } + + tcConfigB.optSettings <- + { tcConfigB.optSettings with + crossAssemblyOptimizationUser = Some false + } + + tcConfigB.optSettings <- + { tcConfigB.optSettings with + lambdaInlineThreshold = 0 + } + tcConfigB.doDetuple <- false tcConfigB.doTLR <- false tcConfigB.doFinalSimplify <- false -let SetOptimizeOn(tcConfigB: TcConfigBuilder) = - tcConfigB.optSettings <- { tcConfigB.optSettings with jitOptUser = Some true } - tcConfigB.optSettings <- { tcConfigB.optSettings with localOptUser = Some true } - tcConfigB.optSettings <- { tcConfigB.optSettings with crossAssemblyOptimizationUser = Some true } - tcConfigB.optSettings <- { tcConfigB.optSettings with lambdaInlineThreshold = 6 } +let SetOptimizeOn (tcConfigB: TcConfigBuilder) = + tcConfigB.optSettings <- + { tcConfigB.optSettings with + jitOptUser = Some true + } + + tcConfigB.optSettings <- + { tcConfigB.optSettings with + localOptUser = Some true + } + + tcConfigB.optSettings <- + { tcConfigB.optSettings with + crossAssemblyOptimizationUser = Some true + } + + tcConfigB.optSettings <- + { tcConfigB.optSettings with + lambdaInlineThreshold = 6 + } + tcConfigB.doDetuple <- true tcConfigB.doTLR <- true tcConfigB.doFinalSimplify <- true let SetOptimizeSwitch (tcConfigB: TcConfigBuilder) switch = - if (switch = OptionSwitch.On) then SetOptimizeOn tcConfigB else SetOptimizeOff tcConfigB + if (switch = OptionSwitch.On) then + SetOptimizeOn tcConfigB + else + SetOptimizeOff tcConfigB let SetTailcallSwitch (tcConfigB: TcConfigBuilder) switch = tcConfigB.emitTailcalls <- (switch = OptionSwitch.On) @@ -409,38 +554,50 @@ let SetDeterministicSwitch (tcConfigB: TcConfigBuilder) switch = let SetReferenceAssemblyOnlySwitch (tcConfigB: TcConfigBuilder) switch = match tcConfigB.emitMetadataAssembly with | MetadataAssemblyGeneration.None -> - tcConfigB.emitMetadataAssembly <- if (switch = OptionSwitch.On) then MetadataAssemblyGeneration.ReferenceOnly else MetadataAssemblyGeneration.None - | _ -> - error(Error(FSComp.SR.optsInvalidRefAssembly(), rangeCmdArgs)) + tcConfigB.emitMetadataAssembly <- + if (switch = OptionSwitch.On) then + MetadataAssemblyGeneration.ReferenceOnly + else + MetadataAssemblyGeneration.None + | _ -> error (Error(FSComp.SR.optsInvalidRefAssembly (), rangeCmdArgs)) let SetReferenceAssemblyOutSwitch (tcConfigB: TcConfigBuilder) outputPath = match tcConfigB.emitMetadataAssembly with - | MetadataAssemblyGeneration.None -> + | MetadataAssemblyGeneration.None -> if FileSystem.IsInvalidPathShim outputPath then - error(Error(FSComp.SR.optsInvalidRefOut(), rangeCmdArgs)) + error (Error(FSComp.SR.optsInvalidRefOut (), rangeCmdArgs)) else tcConfigB.emitMetadataAssembly <- MetadataAssemblyGeneration.ReferenceOut outputPath - | _ -> - error(Error(FSComp.SR.optsInvalidRefAssembly(), rangeCmdArgs)) + | _ -> error (Error(FSComp.SR.optsInvalidRefAssembly (), rangeCmdArgs)) let AddPathMapping (tcConfigB: TcConfigBuilder) (pathPair: string) = - match pathPair.Split([|'='|], 2) with - | [| oldPrefix; newPrefix |] -> - tcConfigB.AddPathMapping (oldPrefix, newPrefix) - | _ -> - error(Error(FSComp.SR.optsInvalidPathMapFormat(), rangeCmdArgs)) + match pathPair.Split([| '=' |], 2) with + | [| oldPrefix; newPrefix |] -> tcConfigB.AddPathMapping(oldPrefix, newPrefix) + | _ -> error (Error(FSComp.SR.optsInvalidPathMapFormat (), rangeCmdArgs)) let jitoptimizeSwitch (tcConfigB: TcConfigBuilder) switch = - tcConfigB.optSettings <- { tcConfigB.optSettings with jitOptUser = Some (switch = OptionSwitch.On) } + tcConfigB.optSettings <- + { tcConfigB.optSettings with + jitOptUser = Some(switch = OptionSwitch.On) + } let localoptimizeSwitch (tcConfigB: TcConfigBuilder) switch = - tcConfigB.optSettings <- { tcConfigB.optSettings with localOptUser = Some (switch = OptionSwitch.On) } + tcConfigB.optSettings <- + { tcConfigB.optSettings with + localOptUser = Some(switch = OptionSwitch.On) + } let crossOptimizeSwitch (tcConfigB: TcConfigBuilder) switch = - tcConfigB.optSettings <- { tcConfigB.optSettings with crossAssemblyOptimizationUser = Some (switch = OptionSwitch.On) } + tcConfigB.optSettings <- + { tcConfigB.optSettings with + crossAssemblyOptimizationUser = Some(switch = OptionSwitch.On) + } let splittingSwitch (tcConfigB: TcConfigBuilder) switch = - tcConfigB.optSettings <- { tcConfigB.optSettings with abstractBigTargets = switch = OptionSwitch.On } + tcConfigB.optSettings <- + { tcConfigB.optSettings with + abstractBigTargets = switch = OptionSwitch.On + } let callVirtSwitch (tcConfigB: TcConfigBuilder) switch = tcConfigB.alwaysCallVirt <- switch = OptionSwitch.On @@ -449,73 +606,79 @@ let useHighEntropyVASwitch (tcConfigB: TcConfigBuilder) switch = tcConfigB.useHighEntropyVA <- switch = OptionSwitch.On let subSystemVersionSwitch (tcConfigB: TcConfigBuilder) (text: string) = - let fail() = error(Error(FSComp.SR.optsInvalidSubSystemVersion text, rangeCmdArgs)) + let fail () = + error (Error(FSComp.SR.optsInvalidSubSystemVersion text, rangeCmdArgs)) // per spec for 357994: Validate input string, should be two positive integers x.y when x>=4 and y>=0 and both <= 65535 if String.IsNullOrEmpty text then - fail() + fail () else match text.Split('.') with - | [| majorStr; minorStr|] -> + | [| majorStr; minorStr |] -> match (Int32.TryParse majorStr), (Int32.TryParse minorStr) with - | (true, major), (true, minor) - when major >= 4 && major <= 65535 - && minor >=0 && minor <= 65535 -> - tcConfigB.subsystemVersion <- (major, minor) - | _ -> fail() - | _ -> fail() + | (true, major), (true, minor) when major >= 4 && major <= 65535 && minor >= 0 && minor <= 65535 -> + tcConfigB.subsystemVersion <- (major, minor) + | _ -> fail () + | _ -> fail () let SetUseSdkSwitch (tcConfigB: TcConfigBuilder) switch = let useSdkRefs = (switch = OptionSwitch.On) tcConfigB.SetUseSdkRefs useSdkRefs -let (++) x s = x @ [s] +let (++) x s = x @ [ s ] -let SetTarget (tcConfigB: TcConfigBuilder)(s: string) = +let SetTarget (tcConfigB: TcConfigBuilder) (s: string) = match s.ToLowerInvariant() with - | "exe" -> tcConfigB.target <- CompilerTarget.ConsoleExe - | "winexe" -> tcConfigB.target <- CompilerTarget.WinExe - | "library" -> tcConfigB.target <- CompilerTarget.Dll - | "module" -> tcConfigB.target <- CompilerTarget.Module - | _ -> error(Error(FSComp.SR.optsUnrecognizedTarget s, rangeCmdArgs)) + | "exe" -> tcConfigB.target <- CompilerTarget.ConsoleExe + | "winexe" -> tcConfigB.target <- CompilerTarget.WinExe + | "library" -> tcConfigB.target <- CompilerTarget.Dll + | "module" -> tcConfigB.target <- CompilerTarget.Module + | _ -> error (Error(FSComp.SR.optsUnrecognizedTarget s, rangeCmdArgs)) let SetDebugSwitch (tcConfigB: TcConfigBuilder) (dtype: string option) (s: OptionSwitch) = match dtype with | Some s -> - match s with - | "portable" -> - tcConfigB.portablePDB <- true - tcConfigB.embeddedPDB <- false - tcConfigB.jitTracking <- true - tcConfigB.ignoreSymbolStoreSequencePoints <- true - | "pdbonly" -> - tcConfigB.portablePDB <- false - tcConfigB.embeddedPDB <- false - tcConfigB.jitTracking <- false - | "embedded" -> - tcConfigB.portablePDB <- true - tcConfigB.embeddedPDB <- true - tcConfigB.jitTracking <- true - tcConfigB.ignoreSymbolStoreSequencePoints <- true + match s with + | "portable" -> + tcConfigB.portablePDB <- true + tcConfigB.embeddedPDB <- false + tcConfigB.jitTracking <- true + tcConfigB.ignoreSymbolStoreSequencePoints <- true + | "pdbonly" -> + tcConfigB.portablePDB <- false + tcConfigB.embeddedPDB <- false + tcConfigB.jitTracking <- false + | "embedded" -> + tcConfigB.portablePDB <- true + tcConfigB.embeddedPDB <- true + tcConfigB.jitTracking <- true + tcConfigB.ignoreSymbolStoreSequencePoints <- true #if FX_NO_PDB_WRITER - // When building on the coreclr, full means portable - | "full" -> - tcConfigB.portablePDB <- true - tcConfigB.embeddedPDB <- false - tcConfigB.jitTracking <- true + // When building on the coreclr, full means portable + | "full" -> + tcConfigB.portablePDB <- true + tcConfigB.embeddedPDB <- false + tcConfigB.jitTracking <- true #else - | "full" -> - tcConfigB.portablePDB <- false - tcConfigB.embeddedPDB <- false - tcConfigB.jitTracking <- true + | "full" -> + tcConfigB.portablePDB <- false + tcConfigB.embeddedPDB <- false + tcConfigB.jitTracking <- true #endif - | _ -> error(Error(FSComp.SR.optsUnrecognizedDebugType s, rangeCmdArgs)) - | None -> tcConfigB.portablePDB <- false; tcConfigB.embeddedPDB <- false; tcConfigB.jitTracking <- s = OptionSwitch.On + | _ -> error (Error(FSComp.SR.optsUnrecognizedDebugType s, rangeCmdArgs)) + | None -> + tcConfigB.portablePDB <- false + tcConfigB.embeddedPDB <- false + tcConfigB.jitTracking <- s = OptionSwitch.On + tcConfigB.debuginfo <- s = OptionSwitch.On let SetEmbedAllSourceSwitch (tcConfigB: TcConfigBuilder) switch = - if (switch = OptionSwitch.On) then tcConfigB.embedAllSource <- true else tcConfigB.embedAllSource <- false + if (switch = OptionSwitch.On) then + tcConfigB.embedAllSource <- true + else + tcConfigB.embedAllSource <- false let setOutFileName tcConfigB path = let outputDir = Path.GetDirectoryName(path) @@ -554,7 +717,7 @@ let tagLangVersionValues = "{?|version|latest|preview}" //---------------- /// Print internal "option state" information for diagnostics and regression tests. -let PrintOptionInfo (tcConfigB:TcConfigBuilder) = +let PrintOptionInfo (tcConfigB: TcConfigBuilder) = printfn " jitOptUser . . . . . . : %+A" tcConfigB.optSettings.jitOptUser printfn " localOptUser . . . . . : %+A" tcConfigB.optSettings.localOptUser printfn " crossAssemblyOptimizationUser . . : %+A" tcConfigB.optSettings.crossAssemblyOptimizationUser @@ -573,28 +736,57 @@ let PrintOptionInfo (tcConfigB:TcConfigBuilder) = printfn " resolutionEnvironment : %+A" tcConfigB.resolutionEnvironment printfn " product . . . . . . . : %+A" tcConfigB.productNameForBannerText printfn " copyFSharpCore . . . . : %+A" tcConfigB.copyFSharpCore - tcConfigB.includes |> List.sort - |> List.iter (printfn " include . . . . . . . : %A") + + tcConfigB.includes + |> List.sort + |> List.iter (printfn " include . . . . . . . : %A") // OptionBlock: Input files //------------------------- -let inputFileFlagsBoth (tcConfigB : TcConfigBuilder) = [ - CompilerOption("reference", tagFile, OptionString (fun s -> tcConfigB.AddReferencedAssemblyByPath (rangeStartup, s)), None, Some (FSComp.SR.optsReference())) - CompilerOption("compilertool", tagFile, OptionString (fun s -> tcConfigB.AddCompilerToolsByPath s), None, Some (FSComp.SR.optsCompilerTool())) +let inputFileFlagsBoth (tcConfigB: TcConfigBuilder) = + [ + CompilerOption( + "reference", + tagFile, + OptionString(fun s -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup, s)), + None, + Some(FSComp.SR.optsReference ()) + ) + CompilerOption( + "compilertool", + tagFile, + OptionString(fun s -> tcConfigB.AddCompilerToolsByPath s), + None, + Some(FSComp.SR.optsCompilerTool ()) + ) ] -let referenceFlagAbbrev (tcConfigB : TcConfigBuilder) = - CompilerOption("r", tagFile, OptionString (fun s -> tcConfigB.AddReferencedAssemblyByPath (rangeStartup, s)), None, Some(FSComp.SR.optsShortFormOf("--reference"))) +let referenceFlagAbbrev (tcConfigB: TcConfigBuilder) = + CompilerOption( + "r", + tagFile, + OptionString(fun s -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup, s)), + None, + Some(FSComp.SR.optsShortFormOf ("--reference")) + ) -let compilerToolFlagAbbrev (tcConfigB : TcConfigBuilder) = - CompilerOption("t", tagFile, OptionString (fun s -> tcConfigB.AddCompilerToolsByPath s), None, Some(FSComp.SR.optsShortFormOf("--compilertool"))) +let compilerToolFlagAbbrev (tcConfigB: TcConfigBuilder) = + CompilerOption( + "t", + tagFile, + OptionString(fun s -> tcConfigB.AddCompilerToolsByPath s), + None, + Some(FSComp.SR.optsShortFormOf ("--compilertool")) + ) let inputFileFlagsFsc tcConfigB = inputFileFlagsBoth tcConfigB let inputFileFlagsFsiBase (_tcConfigB: TcConfigBuilder) = #if NETSTANDARD - [ CompilerOption("usesdkrefs", tagNone, OptionSwitch (SetUseSdkSwitch _tcConfigB), None, Some (FSComp.SR.useSdkRefs())) ] + [ + CompilerOption("usesdkrefs", tagNone, OptionSwitch(SetUseSdkSwitch _tcConfigB), None, Some(FSComp.SR.useSdkRefs ())) + ] #else List.empty #endif @@ -606,49 +798,92 @@ let inputFileFlagsFsi (tcConfigB: TcConfigBuilder) = //--------------------------------- let errorsAndWarningsFlags (tcConfigB: TcConfigBuilder) = - let trimFS (s:string) = if s.StartsWithOrdinal "FS" then s.Substring 2 else s - let trimFStoInt (s:string) = - match Int32.TryParse (trimFS s) with - | true, n -> Some n + let trimFS (s: string) = + if s.StartsWithOrdinal "FS" then s.Substring 2 else s + + let trimFStoInt (s: string) = + match Int32.TryParse(trimFS s) with + | true, n -> Some n | false, _ -> None + [ - CompilerOption("warnaserror", tagNone, OptionSwitch(fun switch -> - tcConfigB.diagnosticsOptions <- - { tcConfigB.diagnosticsOptions with - GlobalWarnAsError = switch <> OptionSwitch.Off }), None, Some (FSComp.SR.optsWarnaserrorPM())) - - CompilerOption("warnaserror", tagWarnList, OptionStringListSwitch (fun n switch -> - match trimFStoInt n with - | Some n -> - let options = tcConfigB.diagnosticsOptions + CompilerOption( + "warnaserror", + tagNone, + OptionSwitch(fun switch -> tcConfigB.diagnosticsOptions <- - if switch = OptionSwitch.Off then - { options with - WarnAsError = ListSet.remove (=) n options.WarnAsError - WarnAsWarn = ListSet.insert (=) n options.WarnAsWarn } - else - { options with - WarnAsError = ListSet.insert (=) n options.WarnAsError - WarnAsWarn = ListSet.remove (=) n options.WarnAsWarn } - | None -> ()), None, Some (FSComp.SR.optsWarnaserror())) - - CompilerOption("warn", tagInt, OptionInt (fun n -> - tcConfigB.diagnosticsOptions <- - { tcConfigB.diagnosticsOptions with - WarnLevel = if (n >= 0 && n <= 5) then n else error(Error (FSComp.SR.optsInvalidWarningLevel n, rangeCmdArgs)) } - ), None, Some (FSComp.SR.optsWarn())) - - CompilerOption("nowarn", tagWarnList, OptionStringList (fun n -> - tcConfigB.TurnWarningOff(rangeCmdArgs, trimFS n)), None, Some (FSComp.SR.optsNowarn())) - - CompilerOption("warnon", tagWarnList, OptionStringList (fun n -> - tcConfigB.TurnWarningOn(rangeCmdArgs, trimFS n)), None, Some (FSComp.SR.optsWarnOn())) - - CompilerOption("consolecolors", tagNone, OptionSwitch (fun switch -> - enableConsoleColoring <- switch = OptionSwitch.On), None, Some (FSComp.SR.optsConsoleColors())) + { tcConfigB.diagnosticsOptions with + GlobalWarnAsError = switch <> OptionSwitch.Off + }), + None, + Some(FSComp.SR.optsWarnaserrorPM ()) + ) + + CompilerOption( + "warnaserror", + tagWarnList, + OptionStringListSwitch(fun n switch -> + match trimFStoInt n with + | Some n -> + let options = tcConfigB.diagnosticsOptions + + tcConfigB.diagnosticsOptions <- + if switch = OptionSwitch.Off then + { options with + WarnAsError = ListSet.remove (=) n options.WarnAsError + WarnAsWarn = ListSet.insert (=) n options.WarnAsWarn + } + else + { options with + WarnAsError = ListSet.insert (=) n options.WarnAsError + WarnAsWarn = ListSet.remove (=) n options.WarnAsWarn + } + | None -> ()), + None, + Some(FSComp.SR.optsWarnaserror ()) + ) + + CompilerOption( + "warn", + tagInt, + OptionInt(fun n -> + tcConfigB.diagnosticsOptions <- + { tcConfigB.diagnosticsOptions with + WarnLevel = + if (n >= 0 && n <= 5) then + n + else + error (Error(FSComp.SR.optsInvalidWarningLevel n, rangeCmdArgs)) + }), + None, + Some(FSComp.SR.optsWarn ()) + ) + + CompilerOption( + "nowarn", + tagWarnList, + OptionStringList(fun n -> tcConfigB.TurnWarningOff(rangeCmdArgs, trimFS n)), + None, + Some(FSComp.SR.optsNowarn ()) + ) + + CompilerOption( + "warnon", + tagWarnList, + OptionStringList(fun n -> tcConfigB.TurnWarningOn(rangeCmdArgs, trimFS n)), + None, + Some(FSComp.SR.optsWarnOn ()) + ) + + CompilerOption( + "consolecolors", + tagNone, + OptionSwitch(fun switch -> enableConsoleColoring <- switch = OptionSwitch.On), + None, + Some(FSComp.SR.optsConsoleColors ()) + ) ] - // OptionBlock: Output files //-------------------------- @@ -656,54 +891,40 @@ let outputFileFlagsFsi (_tcConfigB: TcConfigBuilder) = [] let outputFileFlagsFsc (tcConfigB: TcConfigBuilder) = [ - CompilerOption - ("out", tagFile, - OptionString (setOutFileName tcConfigB), None, - Some (FSComp.SR.optsNameOfOutputFile()) ) - - CompilerOption - ("target", tagExe, - OptionString (SetTarget tcConfigB), None, - Some (FSComp.SR.optsBuildConsole())) - - CompilerOption - ("target", tagWinExe, - OptionString (SetTarget tcConfigB), None, - Some (FSComp.SR.optsBuildWindows())) - - CompilerOption - ("target", tagLibrary, - OptionString (SetTarget tcConfigB), None, - Some (FSComp.SR.optsBuildLibrary())) - - CompilerOption - ("target", tagModule, - OptionString (SetTarget tcConfigB), None, - Some (FSComp.SR.optsBuildModule())) - - CompilerOption - ("delaysign", tagNone, - OptionSwitch (fun s -> tcConfigB.delaysign <- (s = OptionSwitch.On)), None, - Some (FSComp.SR.optsDelaySign())) - - CompilerOption - ("publicsign", tagNone, - OptionSwitch (fun s -> tcConfigB.publicsign <- (s = OptionSwitch.On)), None, - Some (FSComp.SR.optsPublicSign())) - - CompilerOption - ("doc", tagFile, - OptionString (fun s -> tcConfigB.xmlDocOutputFile <- Some s), None, - Some (FSComp.SR.optsWriteXml())) - - CompilerOption - ("keyfile", tagFile, - OptionString (fun s -> tcConfigB.signer <- Some s), None, - Some (FSComp.SR.optsStrongKeyFile())) - - CompilerOption - ("platform", tagString, - OptionString (fun s -> + CompilerOption("out", tagFile, OptionString(setOutFileName tcConfigB), None, Some(FSComp.SR.optsNameOfOutputFile ())) + + CompilerOption("target", tagExe, OptionString(SetTarget tcConfigB), None, Some(FSComp.SR.optsBuildConsole ())) + + CompilerOption("target", tagWinExe, OptionString(SetTarget tcConfigB), None, Some(FSComp.SR.optsBuildWindows ())) + + CompilerOption("target", tagLibrary, OptionString(SetTarget tcConfigB), None, Some(FSComp.SR.optsBuildLibrary ())) + + CompilerOption("target", tagModule, OptionString(SetTarget tcConfigB), None, Some(FSComp.SR.optsBuildModule ())) + + CompilerOption( + "delaysign", + tagNone, + OptionSwitch(fun s -> tcConfigB.delaysign <- (s = OptionSwitch.On)), + None, + Some(FSComp.SR.optsDelaySign ()) + ) + + CompilerOption( + "publicsign", + tagNone, + OptionSwitch(fun s -> tcConfigB.publicsign <- (s = OptionSwitch.On)), + None, + Some(FSComp.SR.optsPublicSign ()) + ) + + CompilerOption("doc", tagFile, OptionString(fun s -> tcConfigB.xmlDocOutputFile <- Some s), None, Some(FSComp.SR.optsWriteXml ())) + + CompilerOption("keyfile", tagFile, OptionString(fun s -> tcConfigB.signer <- Some s), None, Some(FSComp.SR.optsStrongKeyFile ())) + + CompilerOption( + "platform", + tagString, + OptionString(fun s -> tcConfigB.platform <- match s with | "x86" -> Some X86 @@ -715,169 +936,187 @@ let outputFileFlagsFsc (tcConfigB: TcConfigBuilder) = tcConfigB.prefer32Bit <- true None | "anycpu" -> None - | _ -> error(Error(FSComp.SR.optsUnknownPlatform s, rangeCmdArgs))), None, - Some(FSComp.SR.optsPlatform())) - - CompilerOption - ("nooptimizationdata", tagNone, - OptionUnit (fun () -> tcConfigB.onlyEssentialOptimizationData <- true), None, - Some (FSComp.SR.optsNoOpt())) - - CompilerOption - ("nointerfacedata", tagNone, - OptionUnit (fun () -> tcConfigB.noSignatureData <- true), None, - Some (FSComp.SR.optsNoInterface())) - - CompilerOption - ("sig", tagFile, - OptionString (setSignatureFile tcConfigB), None, - Some (FSComp.SR.optsSig())) - - CompilerOption - ("allsigs", tagNone, - OptionUnit (setAllSignatureFiles tcConfigB), None, - Some (FSComp.SR.optsAllSigs())) - - CompilerOption - ("nocopyfsharpcore", tagNone, - OptionUnit (fun () -> tcConfigB.copyFSharpCore <- CopyFSharpCoreFlag.No), None, - Some (FSComp.SR.optsNoCopyFsharpCore())) - - CompilerOption - ("refonly", tagNone, - OptionSwitch (SetReferenceAssemblyOnlySwitch tcConfigB), None, - Some (FSComp.SR.optsRefOnly())) - - CompilerOption - ("refout", tagFile, - OptionString (SetReferenceAssemblyOutSwitch tcConfigB), None, - Some (FSComp.SR.optsRefOut())) + | _ -> error (Error(FSComp.SR.optsUnknownPlatform s, rangeCmdArgs))), + None, + Some(FSComp.SR.optsPlatform ()) + ) + + CompilerOption( + "nooptimizationdata", + tagNone, + OptionUnit(fun () -> tcConfigB.onlyEssentialOptimizationData <- true), + None, + Some(FSComp.SR.optsNoOpt ()) + ) + + CompilerOption( + "nointerfacedata", + tagNone, + OptionUnit(fun () -> tcConfigB.noSignatureData <- true), + None, + Some(FSComp.SR.optsNoInterface ()) + ) + + CompilerOption("sig", tagFile, OptionString(setSignatureFile tcConfigB), None, Some(FSComp.SR.optsSig ())) + + CompilerOption("allsigs", tagNone, OptionUnit(setAllSignatureFiles tcConfigB), None, Some(FSComp.SR.optsAllSigs ())) + + CompilerOption( + "nocopyfsharpcore", + tagNone, + OptionUnit(fun () -> tcConfigB.copyFSharpCore <- CopyFSharpCoreFlag.No), + None, + Some(FSComp.SR.optsNoCopyFsharpCore ()) + ) + + CompilerOption("refonly", tagNone, OptionSwitch(SetReferenceAssemblyOnlySwitch tcConfigB), None, Some(FSComp.SR.optsRefOnly ())) + + CompilerOption("refout", tagFile, OptionString(SetReferenceAssemblyOutSwitch tcConfigB), None, Some(FSComp.SR.optsRefOut ())) ] - // OptionBlock: Resources //----------------------- let resourcesFlagsFsi (_tcConfigB: TcConfigBuilder) = [] + let resourcesFlagsFsc (tcConfigB: TcConfigBuilder) = [ - CompilerOption - ("win32icon", tagFile, - OptionString (fun s -> tcConfigB.win32icon <- s), None, - Some (FSComp.SR.optsWin32icon())) - CompilerOption - ("win32res", tagFile, - OptionString (fun s -> tcConfigB.win32res <- s), None, - Some (FSComp.SR.optsWin32res())) - - CompilerOption - ("win32manifest", tagFile, - OptionString (fun s -> tcConfigB.win32manifest <- s), None, - Some (FSComp.SR.optsWin32manifest())) - - CompilerOption - ("nowin32manifest", tagNone, - OptionUnit (fun () -> tcConfigB.includewin32manifest <- false), None, - Some (FSComp.SR.optsNowin32manifest())) - - CompilerOption - ("resource", tagResInfo, - OptionString (fun s -> tcConfigB.AddEmbeddedResource s), None, - Some (FSComp.SR.optsResource())) - - CompilerOption - ("linkresource", tagResInfo, - OptionString (fun s -> tcConfigB.linkResources <- tcConfigB.linkResources ++ s), None, - Some (FSComp.SR.optsLinkresource())) + CompilerOption("win32icon", tagFile, OptionString(fun s -> tcConfigB.win32icon <- s), None, Some(FSComp.SR.optsWin32icon ())) + CompilerOption("win32res", tagFile, OptionString(fun s -> tcConfigB.win32res <- s), None, Some(FSComp.SR.optsWin32res ())) + + CompilerOption( + "win32manifest", + tagFile, + OptionString(fun s -> tcConfigB.win32manifest <- s), + None, + Some(FSComp.SR.optsWin32manifest ()) + ) + + CompilerOption( + "nowin32manifest", + tagNone, + OptionUnit(fun () -> tcConfigB.includewin32manifest <- false), + None, + Some(FSComp.SR.optsNowin32manifest ()) + ) + + CompilerOption( + "resource", + tagResInfo, + OptionString(fun s -> tcConfigB.AddEmbeddedResource s), + None, + Some(FSComp.SR.optsResource ()) + ) + + CompilerOption( + "linkresource", + tagResInfo, + OptionString(fun s -> tcConfigB.linkResources <- tcConfigB.linkResources ++ s), + None, + Some(FSComp.SR.optsLinkresource ()) + ) ] - // OptionBlock: Code generation //----------------------------- let codeGenerationFlags isFsi (tcConfigB: TcConfigBuilder) = let debug = - [ CompilerOption - ("debug", tagNone, - OptionSwitch (SetDebugSwitch tcConfigB None), None, - Some (FSComp.SR.optsDebugPM())) - - CompilerOption - ("debug", tagFullPDBOnlyPortable, - OptionString (fun s -> SetDebugSwitch tcConfigB (Some s) OptionSwitch.On), None, - Some (FSComp.SR.optsDebug(if isFsi then "pdbonly" else "full"))) + [ + CompilerOption("debug", tagNone, OptionSwitch(SetDebugSwitch tcConfigB None), None, Some(FSComp.SR.optsDebugPM ())) + + CompilerOption( + "debug", + tagFullPDBOnlyPortable, + OptionString(fun s -> SetDebugSwitch tcConfigB (Some s) OptionSwitch.On), + None, + Some(FSComp.SR.optsDebug (if isFsi then "pdbonly" else "full")) + ) ] + let embed = - [ CompilerOption - ("embed", tagNone, - OptionSwitch (SetEmbedAllSourceSwitch tcConfigB), None, - Some (FSComp.SR.optsEmbedAllSource())) - - CompilerOption - ("embed", tagFileList, - OptionStringList (fun f -> tcConfigB.AddEmbeddedSourceFile f), None, - Some ( FSComp.SR.optsEmbedSource())) - - CompilerOption - ("sourcelink", tagFile, - OptionString (fun f -> tcConfigB.sourceLink <- f), None, - Some ( FSComp.SR.optsSourceLink())) + [ + CompilerOption("embed", tagNone, OptionSwitch(SetEmbedAllSourceSwitch tcConfigB), None, Some(FSComp.SR.optsEmbedAllSource ())) + + CompilerOption( + "embed", + tagFileList, + OptionStringList(fun f -> tcConfigB.AddEmbeddedSourceFile f), + None, + Some(FSComp.SR.optsEmbedSource ()) + ) + + CompilerOption("sourcelink", tagFile, OptionString(fun f -> tcConfigB.sourceLink <- f), None, Some(FSComp.SR.optsSourceLink ())) ] let codegen = - [ CompilerOption - ("optimize", tagNone, - OptionSwitch (SetOptimizeSwitch tcConfigB), None, - Some (FSComp.SR.optsOptimize())) - - CompilerOption - ("tailcalls", tagNone, - OptionSwitch (SetTailcallSwitch tcConfigB), None, - Some (FSComp.SR.optsTailcalls())) - - CompilerOption - ("deterministic", tagNone, - OptionSwitch (SetDeterministicSwitch tcConfigB), None, - Some (FSComp.SR.optsDeterministic())) - - CompilerOption - ("pathmap", tagPathMap, - OptionStringList (AddPathMapping tcConfigB), None, - Some (FSComp.SR.optsPathMap())) - - CompilerOption - ("crossoptimize", tagNone, - OptionSwitch (crossOptimizeSwitch tcConfigB), None, - Some (FSComp.SR.optsCrossoptimize())) + [ + CompilerOption("optimize", tagNone, OptionSwitch(SetOptimizeSwitch tcConfigB), None, Some(FSComp.SR.optsOptimize ())) + + CompilerOption("tailcalls", tagNone, OptionSwitch(SetTailcallSwitch tcConfigB), None, Some(FSComp.SR.optsTailcalls ())) + + CompilerOption( + "deterministic", + tagNone, + OptionSwitch(SetDeterministicSwitch tcConfigB), + None, + Some(FSComp.SR.optsDeterministic ()) + ) + + CompilerOption("pathmap", tagPathMap, OptionStringList(AddPathMapping tcConfigB), None, Some(FSComp.SR.optsPathMap ())) + + CompilerOption( + "crossoptimize", + tagNone, + OptionSwitch(crossOptimizeSwitch tcConfigB), + None, + Some(FSComp.SR.optsCrossoptimize ()) + ) ] - if isFsi then debug @ codegen - else debug @ embed @ codegen + + if isFsi then debug @ codegen else debug @ embed @ codegen // OptionBlock: Language //---------------------- -let defineSymbol tcConfigB s = tcConfigB.conditionalDefines <- s :: tcConfigB.conditionalDefines +let defineSymbol tcConfigB s = + tcConfigB.conditionalDefines <- s :: tcConfigB.conditionalDefines let mlCompatibilityFlag (tcConfigB: TcConfigBuilder) = - CompilerOption - ("mlcompatibility", tagNone, - OptionUnit (fun () -> tcConfigB.mlCompatibility<-true; tcConfigB.TurnWarningOff(rangeCmdArgs, "62")), None, - Some (FSComp.SR.optsMlcompatibility())) + CompilerOption( + "mlcompatibility", + tagNone, + OptionUnit(fun () -> + tcConfigB.mlCompatibility <- true + tcConfigB.TurnWarningOff(rangeCmdArgs, "62")), + None, + Some(FSComp.SR.optsMlcompatibility ()) + ) /// LanguageVersion management let setLanguageVersion specifiedVersion = let languageVersion = LanguageVersion(specifiedVersion) + let dumpAllowedValues () = - printfn "%s" (FSComp.SR.optsSupportedLangVersions()) - for v in languageVersion.ValidOptions do printfn "%s" v - for v in languageVersion.ValidVersions do printfn "%s" v + printfn "%s" (FSComp.SR.optsSupportedLangVersions ()) + + for v in languageVersion.ValidOptions do + printfn "%s" v + + for v in languageVersion.ValidVersions do + printfn "%s" v + exit 0 - if specifiedVersion = "?" then dumpAllowedValues () - elif specifiedVersion.ToUpperInvariant() = "PREVIEW" then () - elif not (languageVersion.ContainsVersion specifiedVersion) then error(Error(FSComp.SR.optsUnrecognizedLanguageVersion specifiedVersion, rangeCmdArgs)) + if specifiedVersion = "?" then + dumpAllowedValues () + elif specifiedVersion.ToUpperInvariant() = "PREVIEW" then + () + elif not (languageVersion.ContainsVersion specifiedVersion) then + error (Error(FSComp.SR.optsUnrecognizedLanguageVersion specifiedVersion, rangeCmdArgs)) + languageVersion let languageFlags tcConfigB = @@ -888,10 +1127,22 @@ let languageFlags tcConfigB = // 'latest' (latest version, including minor versions), // 'preview' (features for preview) // or specific versions like '4.7' - CompilerOption("langversion", tagLangVersionValues, OptionString (fun switch -> tcConfigB.langVersion <- setLanguageVersion(switch)), None, Some (FSComp.SR.optsLangVersion())) - - CompilerOption("checked", tagNone, OptionSwitch (fun switch -> tcConfigB.checkOverflow <- (switch = OptionSwitch.On)), None, Some (FSComp.SR.optsChecked())) - CompilerOption("define", tagString, OptionString (defineSymbol tcConfigB), None, Some (FSComp.SR.optsDefine())) + CompilerOption( + "langversion", + tagLangVersionValues, + OptionString(fun switch -> tcConfigB.langVersion <- setLanguageVersion (switch)), + None, + Some(FSComp.SR.optsLangVersion ()) + ) + + CompilerOption( + "checked", + tagNone, + OptionSwitch(fun switch -> tcConfigB.checkOverflow <- (switch = OptionSwitch.On)), + None, + Some(FSComp.SR.optsChecked ()) + ) + CompilerOption("define", tagString, OptionString(defineSymbol tcConfigB), None, Some(FSComp.SR.optsDefine ())) mlCompatibilityFlag tcConfigB ] @@ -899,46 +1150,52 @@ let languageFlags tcConfigB = //----------------------------------- let libFlag (tcConfigB: TcConfigBuilder) = - CompilerOption - ("lib", tagDirList, - OptionStringList (fun s -> tcConfigB.AddIncludePath (rangeStartup, s, tcConfigB.implicitIncludeDir)), None, - Some (FSComp.SR.optsLib())) + CompilerOption( + "lib", + tagDirList, + OptionStringList(fun s -> tcConfigB.AddIncludePath(rangeStartup, s, tcConfigB.implicitIncludeDir)), + None, + Some(FSComp.SR.optsLib ()) + ) let codePageFlag (tcConfigB: TcConfigBuilder) = - CompilerOption - ("codepage", tagInt, - OptionInt (fun n -> + CompilerOption( + "codepage", + tagInt, + OptionInt(fun n -> try System.Text.Encoding.GetEncoding n |> ignore with :? ArgumentException as err -> - error(Error(FSComp.SR.optsProblemWithCodepage(n, err.Message), rangeCmdArgs)) + error (Error(FSComp.SR.optsProblemWithCodepage (n, err.Message), rangeCmdArgs)) - tcConfigB.inputCodePage <- Some n), None, - Some (FSComp.SR.optsCodepage())) + tcConfigB.inputCodePage <- Some n), + None, + Some(FSComp.SR.optsCodepage ()) + ) let preferredUiLang (tcConfigB: TcConfigBuilder) = - CompilerOption - ("preferreduilang", tagString, - OptionString (fun s -> tcConfigB.preferredUiLang <- Some s), None, - Some(FSComp.SR.optsPreferredUiLang())) + CompilerOption( + "preferreduilang", + tagString, + OptionString(fun s -> tcConfigB.preferredUiLang <- Some s), + None, + Some(FSComp.SR.optsPreferredUiLang ()) + ) let utf8OutputFlag (tcConfigB: TcConfigBuilder) = - CompilerOption - ("utf8output", tagNone, - OptionUnit (fun () -> tcConfigB.utf8output <- true), None, - Some (FSComp.SR.optsUtf8output())) + CompilerOption("utf8output", tagNone, OptionUnit(fun () -> tcConfigB.utf8output <- true), None, Some(FSComp.SR.optsUtf8output ())) -let fullPathsFlag (tcConfigB: TcConfigBuilder) = - CompilerOption - ("fullpaths", tagNone, - OptionUnit (fun () -> tcConfigB.showFullPaths <- true), None, - Some (FSComp.SR.optsFullpaths())) +let fullPathsFlag (tcConfigB: TcConfigBuilder) = + CompilerOption("fullpaths", tagNone, OptionUnit(fun () -> tcConfigB.showFullPaths <- true), None, Some(FSComp.SR.optsFullpaths ())) let cliRootFlag (_tcConfigB: TcConfigBuilder) = - CompilerOption - ("cliroot", tagString, - OptionString (fun _ -> ()), Some(DeprecatedCommandLineOptionFull(FSComp.SR.optsClirootDeprecatedMsg(), rangeCmdArgs)), - Some(FSComp.SR.optsClirootDescription())) + CompilerOption( + "cliroot", + tagString, + OptionString(fun _ -> ()), + Some(DeprecatedCommandLineOptionFull(FSComp.SR.optsClirootDeprecatedMsg (), rangeCmdArgs)), + Some(FSComp.SR.optsClirootDescription ()) + ) let SetTargetProfile (tcConfigB: TcConfigBuilder) v = let primaryAssembly = @@ -946,108 +1203,122 @@ let SetTargetProfile (tcConfigB: TcConfigBuilder) v = // Indicates we assume "mscorlib.dll", i.e .NET Framework, Mono and Profile 47 | "mscorlib" -> PrimaryAssembly.Mscorlib // Indicates we assume "System.Runtime.dll", i.e .NET Standard 1.x, .NET Core App 1.x and above, and Profile 7/78/259 - | "netcore" -> PrimaryAssembly.System_Runtime + | "netcore" -> PrimaryAssembly.System_Runtime // Indicates we assume "netstandard.dll", i.e .NET Standard 2.0 and above - | "netstandard" -> PrimaryAssembly.NetStandard - | _ -> error(Error(FSComp.SR.optsInvalidTargetProfile v, rangeCmdArgs)) - tcConfigB.SetPrimaryAssembly primaryAssembly + | "netstandard" -> PrimaryAssembly.NetStandard + | _ -> error (Error(FSComp.SR.optsInvalidTargetProfile v, rangeCmdArgs)) + + tcConfigB.SetPrimaryAssembly primaryAssembly let advancedFlagsBoth tcConfigB = [ - yield codePageFlag tcConfigB - yield utf8OutputFlag tcConfigB - yield preferredUiLang tcConfigB - yield fullPathsFlag tcConfigB - yield libFlag tcConfigB - yield CompilerOption - ("simpleresolution", - tagNone, - OptionUnit (fun () -> tcConfigB.useSimpleResolution<-true), None, - Some (FSComp.SR.optsSimpleresolution())) - - yield CompilerOption - ("targetprofile", tagString, - OptionString (SetTargetProfile tcConfigB), None, - Some(FSComp.SR.optsTargetProfile())) + codePageFlag tcConfigB + utf8OutputFlag tcConfigB + preferredUiLang tcConfigB + fullPathsFlag tcConfigB + libFlag tcConfigB + CompilerOption( + "simpleresolution", + tagNone, + OptionUnit(fun () -> tcConfigB.useSimpleResolution <- true), + None, + Some(FSComp.SR.optsSimpleresolution ()) + ) + + CompilerOption("targetprofile", tagString, OptionString(SetTargetProfile tcConfigB), None, Some(FSComp.SR.optsTargetProfile ())) ] let noFrameworkFlag isFsc tcConfigB = - CompilerOption - ("noframework", tagNone, - OptionUnit (fun () -> + CompilerOption( + "noframework", + tagNone, + OptionUnit(fun () -> tcConfigB.implicitlyReferenceDotNetAssemblies <- false - if isFsc then - tcConfigB.implicitlyResolveAssemblies <- false), None, - Some (FSComp.SR.optsNoframework())) + if isFsc then tcConfigB.implicitlyResolveAssemblies <- false), + None, + Some(FSComp.SR.optsNoframework ()) + ) let advancedFlagsFsi tcConfigB = - advancedFlagsBoth tcConfigB @ - [ - yield noFrameworkFlag false tcConfigB - ] + advancedFlagsBoth tcConfigB @ [ noFrameworkFlag false tcConfigB ] let advancedFlagsFsc tcConfigB = - advancedFlagsBoth tcConfigB @ - [ - yield CompilerOption - ("baseaddress", tagAddress, - OptionString (fun s -> tcConfigB.baseAddress <- Some(int32 s)), None, - Some (FSComp.SR.optsBaseaddress())) - - yield CompilerOption - ("checksumalgorithm", tagAlgorithm, - OptionString (fun s -> - tcConfigB.checksumAlgorithm <- - match s.ToUpperInvariant() with - | "SHA1" -> HashAlgorithm.Sha1 - | "SHA256" -> HashAlgorithm.Sha256 - | _ -> error(Error(FSComp.SR.optsUnknownChecksumAlgorithm s, rangeCmdArgs))), None, - Some (FSComp.SR.optsChecksumAlgorithm())) - - yield noFrameworkFlag true tcConfigB - - yield CompilerOption - ("standalone", tagNone, - OptionUnit (fun _ -> - tcConfigB.openDebugInformationForLaterStaticLinking <- true - tcConfigB.standalone <- true - tcConfigB.implicitlyResolveAssemblies <- true), None, - Some (FSComp.SR.optsStandalone())) - - yield CompilerOption - ("staticlink", tagFile, - OptionString (fun s -> - tcConfigB.extraStaticLinkRoots <- tcConfigB.extraStaticLinkRoots @ [s] - tcConfigB.implicitlyResolveAssemblies <- true), None, - Some (FSComp.SR.optsStaticlink())) + advancedFlagsBoth tcConfigB + @ [ + CompilerOption( + "baseaddress", + tagAddress, + OptionString(fun s -> tcConfigB.baseAddress <- Some(int32 s)), + None, + Some(FSComp.SR.optsBaseaddress ()) + ) + + CompilerOption( + "checksumalgorithm", + tagAlgorithm, + OptionString(fun s -> + tcConfigB.checksumAlgorithm <- + match s.ToUpperInvariant() with + | "SHA1" -> HashAlgorithm.Sha1 + | "SHA256" -> HashAlgorithm.Sha256 + | _ -> error (Error(FSComp.SR.optsUnknownChecksumAlgorithm s, rangeCmdArgs))), + None, + Some(FSComp.SR.optsChecksumAlgorithm ()) + ) + + noFrameworkFlag true tcConfigB + + CompilerOption( + "standalone", + tagNone, + OptionUnit(fun _ -> + tcConfigB.openDebugInformationForLaterStaticLinking <- true + tcConfigB.standalone <- true + tcConfigB.implicitlyResolveAssemblies <- true), + None, + Some(FSComp.SR.optsStandalone ()) + ) + + CompilerOption( + "staticlink", + tagFile, + OptionString(fun s -> + tcConfigB.extraStaticLinkRoots <- tcConfigB.extraStaticLinkRoots @ [ s ] + tcConfigB.implicitlyResolveAssemblies <- true), + None, + Some(FSComp.SR.optsStaticlink ()) + ) #if ENABLE_MONO_SUPPORT if runningOnMono then - yield CompilerOption - ("resident", tagFile, - OptionUnit (fun () -> ()), None, - Some (FSComp.SR.optsResident())) + CompilerOption("resident", tagFile, OptionUnit(fun () -> ()), None, Some(FSComp.SR.optsResident ())) #endif - yield CompilerOption - ("pdb", tagString, - OptionString (fun s -> tcConfigB.debugSymbolFile <- Some s), None, - Some (FSComp.SR.optsPdb())) - - yield CompilerOption - ("highentropyva", tagNone, - OptionSwitch (useHighEntropyVASwitch tcConfigB), None, - Some (FSComp.SR.optsUseHighEntropyVA())) - - yield CompilerOption - ("subsystemversion", tagString, - OptionString (subSystemVersionSwitch tcConfigB), None, - Some (FSComp.SR.optsSubSystemVersion())) - - yield CompilerOption - ("quotations-debug", tagNone, - OptionSwitch(fun switch -> tcConfigB.emitDebugInfoInQuotations <- switch = OptionSwitch.On), None, - Some(FSComp.SR.optsEmitDebugInfoInQuotations())) + CompilerOption("pdb", tagString, OptionString(fun s -> tcConfigB.debugSymbolFile <- Some s), None, Some(FSComp.SR.optsPdb ())) + + CompilerOption( + "highentropyva", + tagNone, + OptionSwitch(useHighEntropyVASwitch tcConfigB), + None, + Some(FSComp.SR.optsUseHighEntropyVA ()) + ) + + CompilerOption( + "subsystemversion", + tagString, + OptionString(subSystemVersionSwitch tcConfigB), + None, + Some(FSComp.SR.optsSubSystemVersion ()) + ) + + CompilerOption( + "quotations-debug", + tagNone, + OptionSwitch(fun switch -> tcConfigB.emitDebugInfoInQuotations <- switch = OptionSwitch.On), + None, + Some(FSComp.SR.optsEmitDebugInfoInQuotations ()) + ) ] @@ -1055,415 +1326,641 @@ let advancedFlagsFsc tcConfigB = //-------------------------------------------------- let testFlag tcConfigB = - CompilerOption - ("test", tagString, - OptionString (fun s -> - match s with - | "StackSpan" -> tcConfigB.internalTestSpanStackReferring <- true - | "ErrorRanges" -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Test - | "Tracking" -> tracking <- true (* general purpose on/off diagnostics flag *) - | "NoNeedToTailcall" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportNoNeedToTailcall = true } - | "FunctionSizes" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportFunctionSizes = true } - | "TotalSizes" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportTotalSizes = true } - | "HasEffect" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportHasEffect = true } - | "NoErrorText" -> FSComp.SR.SwallowResourceText <- true - | "EmitFeeFeeAs100001" -> tcConfigB.testFlagEmitFeeFeeAs100001 <- true - | "DumpDebugInfo" -> tcConfigB.dumpDebugInfo <- true - | "ShowLoadedAssemblies" -> tcConfigB.showLoadedAssemblies <- true - | "ContinueAfterParseFailure" -> tcConfigB.continueAfterParseFailure <- true - | "ParallelOff" -> tcConfigB.concurrentBuild <- false + CompilerOption( + "test", + tagString, + OptionString(fun s -> + match s with + | "StackSpan" -> tcConfigB.internalTestSpanStackReferring <- true + | "ErrorRanges" -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Test + | "Tracking" -> tracking <- true (* general purpose on/off diagnostics flag *) + | "NoNeedToTailcall" -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + reportNoNeedToTailcall = true + } + | "FunctionSizes" -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + reportFunctionSizes = true + } + | "TotalSizes" -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + reportTotalSizes = true + } + | "HasEffect" -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + reportHasEffect = true + } + | "NoErrorText" -> FSComp.SR.SwallowResourceText <- true + | "EmitFeeFeeAs100001" -> tcConfigB.testFlagEmitFeeFeeAs100001 <- true + | "DumpDebugInfo" -> tcConfigB.dumpDebugInfo <- true + | "ShowLoadedAssemblies" -> tcConfigB.showLoadedAssemblies <- true + | "ContinueAfterParseFailure" -> tcConfigB.continueAfterParseFailure <- true + | "ParallelOff" -> tcConfigB.concurrentBuild <- false #if DEBUG - | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true + | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true #endif - | str -> warning(Error(FSComp.SR.optsUnknownArgumentToTheTestSwitch str, rangeCmdArgs))), None, - None) + | str -> warning (Error(FSComp.SR.optsUnknownArgumentToTheTestSwitch str, rangeCmdArgs))), + None, + None + ) // Not shown in fsc.exe help, no warning on use, motivation is for use from tooling. let editorSpecificFlags (tcConfigB: TcConfigBuilder) = - [ CompilerOption("vserrors", tagNone, OptionUnit (fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.VisualStudio), None, None) - CompilerOption("validate-type-providers", tagNone, OptionUnit id, None, None) // preserved for compatibility's sake, no longer has any effect - CompilerOption("LCID", tagInt, OptionInt ignore, None, None) - CompilerOption("flaterrors", tagNone, OptionUnit (fun () -> tcConfigB.flatErrors <- true), None, None) - CompilerOption("sqmsessionguid", tagNone, OptionString ignore, None, None) - CompilerOption("gccerrors", tagNone, OptionUnit (fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Gcc), None, None) - CompilerOption("exename", tagNone, OptionString (fun s -> tcConfigB.exename <- Some s), None, None) - CompilerOption("maxerrors", tagInt, OptionInt (fun n -> tcConfigB.maxErrors <- n), None, None) - CompilerOption("noconditionalerasure", tagNone, OptionUnit (fun () -> tcConfigB.noConditionalErasure <- true), None, None) - ] - -let internalFlags (tcConfigB:TcConfigBuilder) = - [ - CompilerOption - ("stamps", tagNone, - OptionUnit ignore, - Some(InternalCommandLineOption("--stamps", rangeCmdArgs)), None) - - CompilerOption - ("ranges", tagNone, - OptionSet DebugPrint.layoutRanges, - Some(InternalCommandLineOption("--ranges", rangeCmdArgs)), None) - - CompilerOption - ("terms", tagNone, - OptionUnit (fun () -> tcConfigB.showTerms <- true), - Some(InternalCommandLineOption("--terms", rangeCmdArgs)), None) - - CompilerOption - ("termsfile", tagNone, - OptionUnit (fun () -> tcConfigB.writeTermsToFiles <- true), - Some(InternalCommandLineOption("--termsfile", rangeCmdArgs)), None) + [ + CompilerOption("vserrors", tagNone, OptionUnit(fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.VisualStudio), None, None) + CompilerOption("validate-type-providers", tagNone, OptionUnit id, None, None) // preserved for compatibility's sake, no longer has any effect + CompilerOption("LCID", tagInt, OptionInt ignore, None, None) + CompilerOption("flaterrors", tagNone, OptionUnit(fun () -> tcConfigB.flatErrors <- true), None, None) + CompilerOption("sqmsessionguid", tagNone, OptionString ignore, None, None) + CompilerOption("gccerrors", tagNone, OptionUnit(fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Gcc), None, None) + CompilerOption("exename", tagNone, OptionString(fun s -> tcConfigB.exename <- Some s), None, None) + CompilerOption("maxerrors", tagInt, OptionInt(fun n -> tcConfigB.maxErrors <- n), None, None) + CompilerOption("noconditionalerasure", tagNone, OptionUnit(fun () -> tcConfigB.noConditionalErasure <- true), None, None) + ] + +let internalFlags (tcConfigB: TcConfigBuilder) = + [ + CompilerOption("stamps", tagNone, OptionUnit ignore, Some(InternalCommandLineOption("--stamps", rangeCmdArgs)), None) + + CompilerOption( + "ranges", + tagNone, + OptionSet DebugPrint.layoutRanges, + Some(InternalCommandLineOption("--ranges", rangeCmdArgs)), + None + ) + + CompilerOption( + "terms", + tagNone, + OptionUnit(fun () -> tcConfigB.showTerms <- true), + Some(InternalCommandLineOption("--terms", rangeCmdArgs)), + None + ) + + CompilerOption( + "termsfile", + tagNone, + OptionUnit(fun () -> tcConfigB.writeTermsToFiles <- true), + Some(InternalCommandLineOption("--termsfile", rangeCmdArgs)), + None + ) #if DEBUG - CompilerOption - ("debug-parse", tagNone, - OptionUnit (fun () -> Internal.Utilities.Text.Parsing.Flags.debug <- true), - Some(InternalCommandLineOption("--debug-parse", rangeCmdArgs)), None) + CompilerOption( + "debug-parse", + tagNone, + OptionUnit(fun () -> Internal.Utilities.Text.Parsing.Flags.debug <- true), + Some(InternalCommandLineOption("--debug-parse", rangeCmdArgs)), + None + ) #endif - CompilerOption - ("pause", tagNone, - OptionUnit (fun () -> tcConfigB.pause <- true), - Some(InternalCommandLineOption("--pause", rangeCmdArgs)), None) - - CompilerOption - ("detuple", tagNone, - OptionInt (setFlag (fun v -> tcConfigB.doDetuple <- v)), - Some(InternalCommandLineOption("--detuple", rangeCmdArgs)), None) - - CompilerOption - ("simulateException", tagNone, - OptionString (fun s -> tcConfigB.simulateException <- Some s), - Some(InternalCommandLineOption("--simulateException", rangeCmdArgs)), Some "Simulate an exception from some part of the compiler") - - CompilerOption - ("stackReserveSize", tagNone, - OptionString (fun s -> tcConfigB.stackReserveSize <- Some(int32 s)), - Some(InternalCommandLineOption("--stackReserveSize", rangeCmdArgs)), Some "for an exe, set stack reserve size") - - CompilerOption - ("tlr", tagInt, - OptionInt (setFlag (fun v -> tcConfigB.doTLR <- v)), - Some(InternalCommandLineOption("--tlr", rangeCmdArgs)), None) - - CompilerOption - ("finalSimplify", tagInt, - OptionInt (setFlag (fun v -> tcConfigB.doFinalSimplify <- v)), - Some(InternalCommandLineOption("--finalSimplify", rangeCmdArgs)), None) - - CompilerOption - ("parseonly", tagNone, - OptionUnit (fun () -> tcConfigB.parseOnly <- true), - Some(InternalCommandLineOption("--parseonly", rangeCmdArgs)), None) - - CompilerOption - ("typecheckonly", tagNone, - OptionUnit (fun () -> tcConfigB.typeCheckOnly <- true), - Some(InternalCommandLineOption("--typecheckonly", rangeCmdArgs)), None) - - CompilerOption - ("ast", tagNone, - OptionUnit (fun () -> tcConfigB.printAst <- true), - Some(InternalCommandLineOption("--ast", rangeCmdArgs)), None) - - CompilerOption - ("tokenize", tagNone, - OptionUnit (fun () -> tcConfigB.tokenize <- TokenizeOption.Only), - Some(InternalCommandLineOption("--tokenize", rangeCmdArgs)), None) - - CompilerOption - ("tokenize-unfiltered", tagNone, - OptionUnit (fun () -> tcConfigB.tokenize <- TokenizeOption.Unfiltered), - Some(InternalCommandLineOption("--tokenize-unfiltered", rangeCmdArgs)), None) - - CompilerOption - ("testInteractionParser", tagNone, - OptionUnit (fun () -> tcConfigB.testInteractionParser <- true), - Some(InternalCommandLineOption("--testInteractionParser", rangeCmdArgs)), None) - - CompilerOption - ("testparsererrorrecovery", tagNone, - OptionUnit (fun () -> tcConfigB.reportNumDecls <- true), - Some(InternalCommandLineOption("--testparsererrorrecovery", rangeCmdArgs)), None) - - CompilerOption - ("inlinethreshold", tagInt, - OptionInt (fun n -> tcConfigB.optSettings <- { tcConfigB.optSettings with lambdaInlineThreshold = n }), - Some(InternalCommandLineOption("--inlinethreshold", rangeCmdArgs)), None) - - CompilerOption - ("extraoptimizationloops", tagNone, - OptionInt (fun n -> tcConfigB.extraOptimizationIterations <- n), - Some(InternalCommandLineOption("--extraoptimizationloops", rangeCmdArgs)), None) - - CompilerOption - ("abortonerror", tagNone, - OptionUnit (fun () -> tcConfigB.abortOnError <- true), - Some(InternalCommandLineOption("--abortonerror", rangeCmdArgs)), None) - - CompilerOption - ("implicitresolution", tagNone, - OptionUnit (fun _ -> tcConfigB.implicitlyResolveAssemblies <- true), - Some(InternalCommandLineOption("--implicitresolution", rangeCmdArgs)), None) - - // "Display assembly reference resolution information") - CompilerOption - ("resolutions", tagNone, - OptionUnit (fun () -> tcConfigB.showReferenceResolutions <- true), - Some(InternalCommandLineOption("", rangeCmdArgs)), None) - - // "The base registry key to use for assembly resolution. This part in brackets here: HKEY_LOCAL_MACHINE\[SOFTWARE\Microsoft\.NETFramework]\v2.0.50727\AssemblyFoldersEx") - CompilerOption - ("resolutionframeworkregistrybase", tagString, - OptionString (fun _ -> ()), - Some(InternalCommandLineOption("", rangeCmdArgs)), None) - - // "The base registry key to use for assembly resolution. This part in brackets here: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\.NETFramework\v2.0.50727\[AssemblyFoldersEx]") - CompilerOption - ("resolutionassemblyfoldersuffix", tagString, - OptionString (fun _ -> ()), - Some(InternalCommandLineOption("resolutionassemblyfoldersuffix", rangeCmdArgs)), None) - - // "Additional reference resolution conditions. For example \"OSVersion=5.1.2600.0, PlatformID=id") - CompilerOption - ("resolutionassemblyfoldersconditions", tagString, - OptionString (fun _ -> ()), - Some(InternalCommandLineOption("resolutionassemblyfoldersconditions", rangeCmdArgs)), None) - - // "Resolve assembly references using MSBuild resolution rules rather than directory based (Default=true except when running fsc.exe under mono)") - CompilerOption - ("msbuildresolution", tagNone, - OptionUnit (fun () -> tcConfigB.useSimpleResolution <- false), - Some(InternalCommandLineOption("msbuildresolution", rangeCmdArgs)), None) - - CompilerOption - ("alwayscallvirt", tagNone, - OptionSwitch(callVirtSwitch tcConfigB), - Some(InternalCommandLineOption("alwayscallvirt", rangeCmdArgs)), None) - - CompilerOption - ("nodebugdata", tagNone, - OptionUnit (fun () -> tcConfigB.noDebugAttributes <- true), - Some(InternalCommandLineOption("nodebugdata", rangeCmdArgs)), None) - - testFlag tcConfigB ] @ - - editorSpecificFlags tcConfigB @ - [ CompilerOption - ("jit", tagNone, - OptionSwitch (jitoptimizeSwitch tcConfigB), - Some(InternalCommandLineOption("jit", rangeCmdArgs)), None) - - CompilerOption - ("localoptimize", tagNone, - OptionSwitch(localoptimizeSwitch tcConfigB), - Some(InternalCommandLineOption("localoptimize", rangeCmdArgs)), None) - - CompilerOption - ("splitting", tagNone, - OptionSwitch(splittingSwitch tcConfigB), - Some(InternalCommandLineOption("splitting", rangeCmdArgs)), None) - - CompilerOption - ("versionfile", tagString, - OptionString (fun s -> tcConfigB.version <- VersionFile s), - Some(InternalCommandLineOption("versionfile", rangeCmdArgs)), None) - - // "Display timing profiles for compilation" - CompilerOption - ("times", tagNone, - OptionUnit (fun () -> tcConfigB.showTimes <- true), - Some(InternalCommandLineOption("times", rangeCmdArgs)), None) + CompilerOption( + "pause", + tagNone, + OptionUnit(fun () -> tcConfigB.pause <- true), + Some(InternalCommandLineOption("--pause", rangeCmdArgs)), + None + ) + + CompilerOption( + "detuple", + tagNone, + OptionInt(setFlag (fun v -> tcConfigB.doDetuple <- v)), + Some(InternalCommandLineOption("--detuple", rangeCmdArgs)), + None + ) + + CompilerOption( + "simulateException", + tagNone, + OptionString(fun s -> tcConfigB.simulateException <- Some s), + Some(InternalCommandLineOption("--simulateException", rangeCmdArgs)), + Some "Simulate an exception from some part of the compiler" + ) + + CompilerOption( + "stackReserveSize", + tagNone, + OptionString(fun s -> tcConfigB.stackReserveSize <- Some(int32 s)), + Some(InternalCommandLineOption("--stackReserveSize", rangeCmdArgs)), + Some "for an exe, set stack reserve size" + ) + + CompilerOption( + "tlr", + tagInt, + OptionInt(setFlag (fun v -> tcConfigB.doTLR <- v)), + Some(InternalCommandLineOption("--tlr", rangeCmdArgs)), + None + ) + + CompilerOption( + "finalSimplify", + tagInt, + OptionInt(setFlag (fun v -> tcConfigB.doFinalSimplify <- v)), + Some(InternalCommandLineOption("--finalSimplify", rangeCmdArgs)), + None + ) + + CompilerOption( + "parseonly", + tagNone, + OptionUnit(fun () -> tcConfigB.parseOnly <- true), + Some(InternalCommandLineOption("--parseonly", rangeCmdArgs)), + None + ) + + CompilerOption( + "typecheckonly", + tagNone, + OptionUnit(fun () -> tcConfigB.typeCheckOnly <- true), + Some(InternalCommandLineOption("--typecheckonly", rangeCmdArgs)), + None + ) + + CompilerOption( + "ast", + tagNone, + OptionUnit(fun () -> tcConfigB.printAst <- true), + Some(InternalCommandLineOption("--ast", rangeCmdArgs)), + None + ) + + CompilerOption( + "tokenize", + tagNone, + OptionUnit(fun () -> tcConfigB.tokenize <- TokenizeOption.Only), + Some(InternalCommandLineOption("--tokenize", rangeCmdArgs)), + None + ) + + CompilerOption( + "tokenize-unfiltered", + tagNone, + OptionUnit(fun () -> tcConfigB.tokenize <- TokenizeOption.Unfiltered), + Some(InternalCommandLineOption("--tokenize-unfiltered", rangeCmdArgs)), + None + ) + + CompilerOption( + "testInteractionParser", + tagNone, + OptionUnit(fun () -> tcConfigB.testInteractionParser <- true), + Some(InternalCommandLineOption("--testInteractionParser", rangeCmdArgs)), + None + ) + + CompilerOption( + "testparsererrorrecovery", + tagNone, + OptionUnit(fun () -> tcConfigB.reportNumDecls <- true), + Some(InternalCommandLineOption("--testparsererrorrecovery", rangeCmdArgs)), + None + ) + + CompilerOption( + "inlinethreshold", + tagInt, + OptionInt(fun n -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + lambdaInlineThreshold = n + }), + Some(InternalCommandLineOption("--inlinethreshold", rangeCmdArgs)), + None + ) + + CompilerOption( + "extraoptimizationloops", + tagNone, + OptionInt(fun n -> tcConfigB.extraOptimizationIterations <- n), + Some(InternalCommandLineOption("--extraoptimizationloops", rangeCmdArgs)), + None + ) + + CompilerOption( + "abortonerror", + tagNone, + OptionUnit(fun () -> tcConfigB.abortOnError <- true), + Some(InternalCommandLineOption("--abortonerror", rangeCmdArgs)), + None + ) + + CompilerOption( + "implicitresolution", + tagNone, + OptionUnit(fun _ -> tcConfigB.implicitlyResolveAssemblies <- true), + Some(InternalCommandLineOption("--implicitresolution", rangeCmdArgs)), + None + ) + + // "Display assembly reference resolution information") + CompilerOption( + "resolutions", + tagNone, + OptionUnit(fun () -> tcConfigB.showReferenceResolutions <- true), + Some(InternalCommandLineOption("", rangeCmdArgs)), + None + ) + + // "The base registry key to use for assembly resolution. This part in brackets here: HKEY_LOCAL_MACHINE\[SOFTWARE\Microsoft\.NETFramework]\v2.0.50727\AssemblyFoldersEx") + CompilerOption( + "resolutionframeworkregistrybase", + tagString, + OptionString(fun _ -> ()), + Some(InternalCommandLineOption("", rangeCmdArgs)), + None + ) + + // "The base registry key to use for assembly resolution. This part in brackets here: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\.NETFramework\v2.0.50727\[AssemblyFoldersEx]") + CompilerOption( + "resolutionassemblyfoldersuffix", + tagString, + OptionString(fun _ -> ()), + Some(InternalCommandLineOption("resolutionassemblyfoldersuffix", rangeCmdArgs)), + None + ) + + // "Additional reference resolution conditions. For example \"OSVersion=5.1.2600.0, PlatformID=id") + CompilerOption( + "resolutionassemblyfoldersconditions", + tagString, + OptionString(fun _ -> ()), + Some(InternalCommandLineOption("resolutionassemblyfoldersconditions", rangeCmdArgs)), + None + ) + + // "Resolve assembly references using MSBuild resolution rules rather than directory based (Default=true except when running fsc.exe under mono)") + CompilerOption( + "msbuildresolution", + tagNone, + OptionUnit(fun () -> tcConfigB.useSimpleResolution <- false), + Some(InternalCommandLineOption("msbuildresolution", rangeCmdArgs)), + None + ) + + CompilerOption( + "alwayscallvirt", + tagNone, + OptionSwitch(callVirtSwitch tcConfigB), + Some(InternalCommandLineOption("alwayscallvirt", rangeCmdArgs)), + None + ) + + CompilerOption( + "nodebugdata", + tagNone, + OptionUnit(fun () -> tcConfigB.noDebugAttributes <- true), + Some(InternalCommandLineOption("nodebugdata", rangeCmdArgs)), + None + ) + + testFlag tcConfigB + ] + @ + + editorSpecificFlags tcConfigB + @ [ + CompilerOption( + "jit", + tagNone, + OptionSwitch(jitoptimizeSwitch tcConfigB), + Some(InternalCommandLineOption("jit", rangeCmdArgs)), + None + ) + + CompilerOption( + "localoptimize", + tagNone, + OptionSwitch(localoptimizeSwitch tcConfigB), + Some(InternalCommandLineOption("localoptimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "splitting", + tagNone, + OptionSwitch(splittingSwitch tcConfigB), + Some(InternalCommandLineOption("splitting", rangeCmdArgs)), + None + ) + + CompilerOption( + "versionfile", + tagString, + OptionString(fun s -> tcConfigB.version <- VersionFile s), + Some(InternalCommandLineOption("versionfile", rangeCmdArgs)), + None + ) + + // "Display timing profiles for compilation" + CompilerOption( + "times", + tagNone, + OptionUnit(fun () -> tcConfigB.showTimes <- true), + Some(InternalCommandLineOption("times", rangeCmdArgs)), + None + ) #if !NO_TYPEPROVIDERS - // "Display information about extension type resolution") - CompilerOption - ("showextensionresolution", tagNone, - OptionUnit (fun () -> tcConfigB.showExtensionTypeMessages <- true), - Some(InternalCommandLineOption("showextensionresolution", rangeCmdArgs)), None) + // "Display information about extension type resolution") + CompilerOption( + "showextensionresolution", + tagNone, + OptionUnit(fun () -> tcConfigB.showExtensionTypeMessages <- true), + Some(InternalCommandLineOption("showextensionresolution", rangeCmdArgs)), + None + ) #endif - CompilerOption - ("metadataversion", tagString, - OptionString (fun s -> tcConfigB.metadataVersion <- Some s), - Some(InternalCommandLineOption("metadataversion", rangeCmdArgs)), None) - ] + CompilerOption( + "metadataversion", + tagString, + OptionString(fun s -> tcConfigB.metadataVersion <- Some s), + Some(InternalCommandLineOption("metadataversion", rangeCmdArgs)), + None + ) + ] // OptionBlock: Deprecated flags (fsc, service only) //-------------------------------------------------- let compilingFsLibFlag (tcConfigB: TcConfigBuilder) = - CompilerOption - ("compiling-fslib", tagNone, - OptionUnit (fun () -> + CompilerOption( + "compiling-fslib", + tagNone, + OptionUnit(fun () -> tcConfigB.compilingFSharpCore <- true tcConfigB.TurnWarningOff(rangeStartup, "42")), - Some(InternalCommandLineOption("--compiling-fslib", rangeCmdArgs)), None) + Some(InternalCommandLineOption("--compiling-fslib", rangeCmdArgs)), + None + ) let compilingFsLib20Flag = - CompilerOption ("compiling-fslib-20", tagNone, OptionString (fun _ -> () ), None, None) + CompilerOption("compiling-fslib-20", tagNone, OptionString(fun _ -> ()), None, None) let compilingFsLib40Flag = - CompilerOption ("compiling-fslib-40", tagNone, OptionUnit (fun () -> ()), None, None) + CompilerOption("compiling-fslib-40", tagNone, OptionUnit(fun () -> ()), None, None) let compilingFsLibNoBigIntFlag = - CompilerOption ("compiling-fslib-nobigint", tagNone, OptionUnit (fun () -> () ), None, None) + CompilerOption("compiling-fslib-nobigint", tagNone, OptionUnit(fun () -> ()), None, None) let mlKeywordsFlag = - CompilerOption - ("ml-keywords", tagNone, - OptionUnit (fun () -> ()), - Some(DeprecatedCommandLineOptionNoDescription("--ml-keywords", rangeCmdArgs)), None) + CompilerOption( + "ml-keywords", + tagNone, + OptionUnit(fun () -> ()), + Some(DeprecatedCommandLineOptionNoDescription("--ml-keywords", rangeCmdArgs)), + None + ) let gnuStyleErrorsFlag tcConfigB = - CompilerOption - ("gnu-style-errors", tagNone, - OptionUnit (fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Emacs), - Some(DeprecatedCommandLineOptionNoDescription("--gnu-style-errors", rangeCmdArgs)), None) + CompilerOption( + "gnu-style-errors", + tagNone, + OptionUnit(fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Emacs), + Some(DeprecatedCommandLineOptionNoDescription("--gnu-style-errors", rangeCmdArgs)), + None + ) let deprecatedFlagsBoth tcConfigB = [ - CompilerOption - ("light", tagNone, - OptionUnit (fun () -> tcConfigB.indentationAwareSyntax <- Some true), - Some(DeprecatedCommandLineOptionNoDescription("--light", rangeCmdArgs)), None) - - CompilerOption - ("indentation-syntax", tagNone, - OptionUnit (fun () -> tcConfigB.indentationAwareSyntax <- Some true), - Some(DeprecatedCommandLineOptionNoDescription("--indentation-syntax", rangeCmdArgs)), None) - - CompilerOption - ("no-indentation-syntax", tagNone, - OptionUnit (fun () -> tcConfigB.indentationAwareSyntax <- Some false), - Some(DeprecatedCommandLineOptionNoDescription("--no-indentation-syntax", rangeCmdArgs)), None) + CompilerOption( + "light", + tagNone, + OptionUnit(fun () -> tcConfigB.indentationAwareSyntax <- Some true), + Some(DeprecatedCommandLineOptionNoDescription("--light", rangeCmdArgs)), + None + ) + + CompilerOption( + "indentation-syntax", + tagNone, + OptionUnit(fun () -> tcConfigB.indentationAwareSyntax <- Some true), + Some(DeprecatedCommandLineOptionNoDescription("--indentation-syntax", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-indentation-syntax", + tagNone, + OptionUnit(fun () -> tcConfigB.indentationAwareSyntax <- Some false), + Some(DeprecatedCommandLineOptionNoDescription("--no-indentation-syntax", rangeCmdArgs)), + None + ) ] let deprecatedFlagsFsi tcConfigB = deprecatedFlagsBoth tcConfigB let deprecatedFlagsFsc tcConfigB = - deprecatedFlagsBoth tcConfigB @ - [ - cliRootFlag tcConfigB - CompilerOption - ("jit-optimize", tagNone, - OptionUnit (fun _ -> tcConfigB.optSettings <- { tcConfigB.optSettings with jitOptUser = Some true }), - Some(DeprecatedCommandLineOptionNoDescription("--jit-optimize", rangeCmdArgs)), None) - - CompilerOption - ("no-jit-optimize", tagNone, - OptionUnit (fun _ -> tcConfigB.optSettings <- { tcConfigB.optSettings with jitOptUser = Some false }), - Some(DeprecatedCommandLineOptionNoDescription("--no-jit-optimize", rangeCmdArgs)), None) - - CompilerOption - ("jit-tracking", tagNone, - OptionUnit (fun _ -> tcConfigB.jitTracking <- true ), - Some(DeprecatedCommandLineOptionNoDescription("--jit-tracking", rangeCmdArgs)), None) - - CompilerOption - ("no-jit-tracking", tagNone, - OptionUnit (fun _ -> tcConfigB.jitTracking <- false ), - Some(DeprecatedCommandLineOptionNoDescription("--no-jit-tracking", rangeCmdArgs)), None) - - CompilerOption - ("progress", tagNone, - OptionUnit (fun () -> progress <- true), - Some(DeprecatedCommandLineOptionNoDescription("--progress", rangeCmdArgs)), None) - - compilingFsLibFlag tcConfigB - compilingFsLib20Flag - compilingFsLib40Flag - compilingFsLibNoBigIntFlag - - CompilerOption - ("version", tagString, - OptionString (fun s -> tcConfigB.version <- VersionString s), - Some(DeprecatedCommandLineOptionNoDescription("--version", rangeCmdArgs)), None) - - CompilerOption - ("local-optimize", tagNone, - OptionUnit (fun _ -> tcConfigB.optSettings <- { tcConfigB.optSettings with localOptUser = Some true }), - Some(DeprecatedCommandLineOptionNoDescription("--local-optimize", rangeCmdArgs)), None) - - CompilerOption - ("no-local-optimize", tagNone, - OptionUnit (fun _ -> tcConfigB.optSettings <- { tcConfigB.optSettings with localOptUser = Some false }), - Some(DeprecatedCommandLineOptionNoDescription("--no-local-optimize", rangeCmdArgs)), None) - - CompilerOption - ("cross-optimize", tagNone, - OptionUnit (fun _ -> tcConfigB.optSettings <- { tcConfigB.optSettings with crossAssemblyOptimizationUser = Some true }), - Some(DeprecatedCommandLineOptionNoDescription("--cross-optimize", rangeCmdArgs)), None) - - CompilerOption - ("no-cross-optimize", tagNone, - OptionUnit (fun _ -> tcConfigB.optSettings <- { tcConfigB.optSettings with crossAssemblyOptimizationUser = Some false }), - Some(DeprecatedCommandLineOptionNoDescription("--no-cross-optimize", rangeCmdArgs)), None) - - CompilerOption - ("no-string-interning", tagNone, - OptionUnit (fun () -> tcConfigB.internConstantStrings <- false), - Some(DeprecatedCommandLineOptionNoDescription("--no-string-interning", rangeCmdArgs)), None) - - CompilerOption - ("statistics", tagNone, - OptionUnit (fun () -> tcConfigB.stats <- true), - Some(DeprecatedCommandLineOptionNoDescription("--statistics", rangeCmdArgs)), None) - - CompilerOption - ("generate-filter-blocks", tagNone, - OptionUnit (fun () -> tcConfigB.generateFilterBlocks <- true), - Some(DeprecatedCommandLineOptionNoDescription("--generate-filter-blocks", rangeCmdArgs)), None) - - //CompilerOption - // ("no-generate-filter-blocks", tagNone, - // OptionUnit (fun () -> tcConfigB.generateFilterBlocks <- false), - // Some(DeprecatedCommandLineOptionNoDescription("--generate-filter-blocks", rangeCmdArgs)), None) - - CompilerOption - ("max-errors", tagInt, - OptionInt (fun n -> tcConfigB.maxErrors <- n), - Some(DeprecatedCommandLineOptionSuggestAlternative("--max-errors", "--maxerrors", rangeCmdArgs)), None) - - CompilerOption - ("debug-file", tagNone, - OptionString (fun s -> tcConfigB.debugSymbolFile <- Some s), - Some(DeprecatedCommandLineOptionSuggestAlternative("--debug-file", "--pdb", rangeCmdArgs)), None) - - CompilerOption - ("no-debug-file", tagNone, - OptionUnit (fun () -> tcConfigB.debuginfo <- false), - Some(DeprecatedCommandLineOptionSuggestAlternative("--no-debug-file", "--debug-", rangeCmdArgs)), None) - - CompilerOption - ("Ooff", tagNone, - OptionUnit (fun () -> SetOptimizeOff tcConfigB), - Some(DeprecatedCommandLineOptionSuggestAlternative("-Ooff", "--optimize-", rangeCmdArgs)), None) - - - CompilerOption - ("keycontainer", tagString, - OptionString(fun s -> - if FSharpEnvironment.isRunningOnCoreClr then error(Error(FSComp.SR.containerSigningUnsupportedOnThisPlatform(), rangeCmdArgs)) - else tcConfigB.container <- Some s), - if FSharpEnvironment.isRunningOnCoreClr then None - else Some(DeprecatedCommandLineOptionSuggestAlternative("--keycontainer", "--keyfile", rangeCmdArgs)) - ,None) - - mlKeywordsFlag - gnuStyleErrorsFlag tcConfigB ] - + deprecatedFlagsBoth tcConfigB + @ [ + cliRootFlag tcConfigB + CompilerOption( + "jit-optimize", + tagNone, + OptionUnit(fun _ -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + jitOptUser = Some true + }), + Some(DeprecatedCommandLineOptionNoDescription("--jit-optimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-jit-optimize", + tagNone, + OptionUnit(fun _ -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + jitOptUser = Some false + }), + Some(DeprecatedCommandLineOptionNoDescription("--no-jit-optimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "jit-tracking", + tagNone, + OptionUnit(fun _ -> tcConfigB.jitTracking <- true), + Some(DeprecatedCommandLineOptionNoDescription("--jit-tracking", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-jit-tracking", + tagNone, + OptionUnit(fun _ -> tcConfigB.jitTracking <- false), + Some(DeprecatedCommandLineOptionNoDescription("--no-jit-tracking", rangeCmdArgs)), + None + ) + + CompilerOption( + "progress", + tagNone, + OptionUnit(fun () -> progress <- true), + Some(DeprecatedCommandLineOptionNoDescription("--progress", rangeCmdArgs)), + None + ) + + compilingFsLibFlag tcConfigB + compilingFsLib20Flag + compilingFsLib40Flag + compilingFsLibNoBigIntFlag + + CompilerOption( + "version", + tagString, + OptionString(fun s -> tcConfigB.version <- VersionString s), + Some(DeprecatedCommandLineOptionNoDescription("--version", rangeCmdArgs)), + None + ) + + CompilerOption( + "local-optimize", + tagNone, + OptionUnit(fun _ -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + localOptUser = Some true + }), + Some(DeprecatedCommandLineOptionNoDescription("--local-optimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-local-optimize", + tagNone, + OptionUnit(fun _ -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + localOptUser = Some false + }), + Some(DeprecatedCommandLineOptionNoDescription("--no-local-optimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "cross-optimize", + tagNone, + OptionUnit(fun _ -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + crossAssemblyOptimizationUser = Some true + }), + Some(DeprecatedCommandLineOptionNoDescription("--cross-optimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-cross-optimize", + tagNone, + OptionUnit(fun _ -> + tcConfigB.optSettings <- + { tcConfigB.optSettings with + crossAssemblyOptimizationUser = Some false + }), + Some(DeprecatedCommandLineOptionNoDescription("--no-cross-optimize", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-string-interning", + tagNone, + OptionUnit(fun () -> tcConfigB.internConstantStrings <- false), + Some(DeprecatedCommandLineOptionNoDescription("--no-string-interning", rangeCmdArgs)), + None + ) + + CompilerOption( + "statistics", + tagNone, + OptionUnit(fun () -> tcConfigB.stats <- true), + Some(DeprecatedCommandLineOptionNoDescription("--statistics", rangeCmdArgs)), + None + ) + + CompilerOption( + "generate-filter-blocks", + tagNone, + OptionUnit(fun () -> tcConfigB.generateFilterBlocks <- true), + Some(DeprecatedCommandLineOptionNoDescription("--generate-filter-blocks", rangeCmdArgs)), + None + ) + + //CompilerOption + // ("no-generate-filter-blocks", tagNone, + // OptionUnit (fun () -> tcConfigB.generateFilterBlocks <- false), + // Some(DeprecatedCommandLineOptionNoDescription("--generate-filter-blocks", rangeCmdArgs)), None) + + CompilerOption( + "max-errors", + tagInt, + OptionInt(fun n -> tcConfigB.maxErrors <- n), + Some(DeprecatedCommandLineOptionSuggestAlternative("--max-errors", "--maxerrors", rangeCmdArgs)), + None + ) + + CompilerOption( + "debug-file", + tagNone, + OptionString(fun s -> tcConfigB.debugSymbolFile <- Some s), + Some(DeprecatedCommandLineOptionSuggestAlternative("--debug-file", "--pdb", rangeCmdArgs)), + None + ) + + CompilerOption( + "no-debug-file", + tagNone, + OptionUnit(fun () -> tcConfigB.debuginfo <- false), + Some(DeprecatedCommandLineOptionSuggestAlternative("--no-debug-file", "--debug-", rangeCmdArgs)), + None + ) + + CompilerOption( + "Ooff", + tagNone, + OptionUnit(fun () -> SetOptimizeOff tcConfigB), + Some(DeprecatedCommandLineOptionSuggestAlternative("-Ooff", "--optimize-", rangeCmdArgs)), + None + ) + + CompilerOption( + "keycontainer", + tagString, + OptionString(fun s -> + if FSharpEnvironment.isRunningOnCoreClr then + error (Error(FSComp.SR.containerSigningUnsupportedOnThisPlatform (), rangeCmdArgs)) + else + tcConfigB.container <- Some s), + (if FSharpEnvironment.isRunningOnCoreClr then + None + else + Some(DeprecatedCommandLineOptionSuggestAlternative("--keycontainer", "--keyfile", rangeCmdArgs))), + None + ) + + mlKeywordsFlag + gnuStyleErrorsFlag tcConfigB + ] // OptionBlock: Miscellaneous options //----------------------------------- let DisplayBannerText tcConfigB = - if tcConfigB.showBanner then ( - printfn "%s" tcConfigB.productNameForBannerText - printfn "%s" (FSComp.SR.optsCopyright()) - ) + if tcConfigB.showBanner then + (printfn "%s" tcConfigB.productNameForBannerText + printfn "%s" (FSComp.SR.optsCopyright ())) /// FSC only help. (FSI has it's own help function). -let displayHelpFsc tcConfigB (blocks:CompilerOptionBlock list) = +let displayHelpFsc tcConfigB (blocks: CompilerOptionBlock list) = DisplayBannerText tcConfigB PrintCompilerOptionBlocks blocks exit 0 @@ -1473,103 +1970,130 @@ let displayVersion tcConfigB = exit 0 let miscFlagsBoth tcConfigB = - [ CompilerOption("nologo", tagNone, OptionUnit (fun () -> tcConfigB.showBanner <- false), None, Some (FSComp.SR.optsNologo())) - CompilerOption("version", tagNone, OptionUnit (fun () -> displayVersion tcConfigB), None, Some (FSComp.SR.optsVersion())) + [ + CompilerOption("nologo", tagNone, OptionUnit(fun () -> tcConfigB.showBanner <- false), None, Some(FSComp.SR.optsNologo ())) + CompilerOption("version", tagNone, OptionUnit(fun () -> displayVersion tcConfigB), None, Some(FSComp.SR.optsVersion ())) ] let miscFlagsFsc tcConfigB = - miscFlagsBoth tcConfigB @ - [ CompilerOption("help", tagNone, OptionHelp (fun blocks -> displayHelpFsc tcConfigB blocks), None, Some (FSComp.SR.optsHelp())) - CompilerOption("@", tagNone, OptionUnit ignore, None, Some (FSComp.SR.optsResponseFile())) + miscFlagsBoth tcConfigB + @ [ + CompilerOption("help", tagNone, OptionHelp(fun blocks -> displayHelpFsc tcConfigB blocks), None, Some(FSComp.SR.optsHelp ())) + CompilerOption("@", tagNone, OptionUnit ignore, None, Some(FSComp.SR.optsResponseFile ())) ] -let miscFlagsFsi tcConfigB = miscFlagsBoth tcConfigB +let miscFlagsFsi tcConfigB = miscFlagsBoth tcConfigB // OptionBlock: Abbreviations of existing options //----------------------------------------------- let abbreviatedFlagsBoth tcConfigB = [ - CompilerOption("d", tagString, OptionString (defineSymbol tcConfigB), None, Some(FSComp.SR.optsShortFormOf("--define"))) - CompilerOption("O", tagNone, OptionSwitch (SetOptimizeSwitch tcConfigB), None, Some(FSComp.SR.optsShortFormOf("--optimize[+|-]"))) - CompilerOption("g", tagNone, OptionSwitch (SetDebugSwitch tcConfigB None), None, Some(FSComp.SR.optsShortFormOf("--debug"))) - CompilerOption("i", tagString, OptionUnit (fun () -> tcConfigB.printSignature <- true), None, Some(FSComp.SR.optsShortFormOf("--sig"))) - CompilerOption("r", tagFile, OptionString (fun s -> tcConfigB.AddReferencedAssemblyByPath (rangeStartup, s)), - None, Some(FSComp.SR.optsShortFormOf("--reference"))) - CompilerOption("I", tagDirList, OptionStringList (fun s -> tcConfigB.AddIncludePath (rangeStartup, s, tcConfigB.implicitIncludeDir)), - None, Some (FSComp.SR.optsShortFormOf("--lib"))) + CompilerOption("d", tagString, OptionString(defineSymbol tcConfigB), None, Some(FSComp.SR.optsShortFormOf ("--define"))) + CompilerOption("O", tagNone, OptionSwitch(SetOptimizeSwitch tcConfigB), None, Some(FSComp.SR.optsShortFormOf ("--optimize[+|-]"))) + CompilerOption("g", tagNone, OptionSwitch(SetDebugSwitch tcConfigB None), None, Some(FSComp.SR.optsShortFormOf ("--debug"))) + CompilerOption( + "i", + tagString, + OptionUnit(fun () -> tcConfigB.printSignature <- true), + None, + Some(FSComp.SR.optsShortFormOf ("--sig")) + ) + CompilerOption( + "r", + tagFile, + OptionString(fun s -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup, s)), + None, + Some(FSComp.SR.optsShortFormOf ("--reference")) + ) + CompilerOption( + "I", + tagDirList, + OptionStringList(fun s -> tcConfigB.AddIncludePath(rangeStartup, s, tcConfigB.implicitIncludeDir)), + None, + Some(FSComp.SR.optsShortFormOf ("--lib")) + ) ] let abbreviatedFlagsFsi tcConfigB = abbreviatedFlagsBoth tcConfigB let abbreviatedFlagsFsc tcConfigB = - abbreviatedFlagsBoth tcConfigB @ - [ // FSC only abbreviated options - CompilerOption - ("o", tagString, - OptionString (setOutFileName tcConfigB), None, - Some(FSComp.SR.optsShortFormOf("--out"))) - - CompilerOption - ("a", tagString, - OptionUnit (fun () -> tcConfigB.target <- CompilerTarget.Dll), None, - Some(FSComp.SR.optsShortFormOf("--target library"))) + abbreviatedFlagsBoth tcConfigB + @ [ // FSC only abbreviated options + CompilerOption("o", tagString, OptionString(setOutFileName tcConfigB), None, Some(FSComp.SR.optsShortFormOf ("--out"))) + + CompilerOption( + "a", + tagString, + OptionUnit(fun () -> tcConfigB.target <- CompilerTarget.Dll), + None, + Some(FSComp.SR.optsShortFormOf ("--target library")) + ) // FSC help abbreviations. FSI has it's own help options... - CompilerOption - ("?", tagNone, - OptionHelp (fun blocks -> displayHelpFsc tcConfigB blocks), None, - Some(FSComp.SR.optsShortFormOf("--help"))) - - CompilerOption - ("help", tagNone, - OptionHelp (fun blocks -> displayHelpFsc tcConfigB blocks), None, - Some(FSComp.SR.optsShortFormOf("--help"))) - - CompilerOption - ("full-help", tagNone, - OptionHelp (fun blocks -> displayHelpFsc tcConfigB blocks), None, - Some(FSComp.SR.optsShortFormOf("--help"))) + CompilerOption( + "?", + tagNone, + OptionHelp(fun blocks -> displayHelpFsc tcConfigB blocks), + None, + Some(FSComp.SR.optsShortFormOf ("--help")) + ) + + CompilerOption( + "help", + tagNone, + OptionHelp(fun blocks -> displayHelpFsc tcConfigB blocks), + None, + Some(FSComp.SR.optsShortFormOf ("--help")) + ) + + CompilerOption( + "full-help", + tagNone, + OptionHelp(fun blocks -> displayHelpFsc tcConfigB blocks), + None, + Some(FSComp.SR.optsShortFormOf ("--help")) + ) ] let GetAbbrevFlagSet tcConfigB isFsc = let mutable argList: string list = [] + for c in ((if isFsc then abbreviatedFlagsFsc else abbreviatedFlagsFsi) tcConfigB) do match c with - | CompilerOption(arg, _, OptionString _, _, _) - | CompilerOption(arg, _, OptionStringList _, _, _) -> argList <- argList @ ["-"+arg;"/"+arg] + | CompilerOption (arg, _, OptionString _, _, _) + | CompilerOption (arg, _, OptionStringList _, _, _) -> argList <- argList @ [ "-" + arg; "/" + arg ] | _ -> () + Set.ofList argList // check for abbreviated options that accept spaces instead of colons, and replace the spaces // with colons when necessary -let PostProcessCompilerArgs (abbrevArgs: string Set) (args: string []) = +let PostProcessCompilerArgs (abbrevArgs: string Set) (args: string[]) = let mutable i = 0 let mutable idx = 0 let len = args.Length let mutable arga: string[] = Array.create len "" while i < len do - if not(abbrevArgs.Contains(args[i])) || i = (len - 1) then + if not (abbrevArgs.Contains(args[i])) || i = (len - 1) then arga[idx] <- args[i] - i <- i+1 + i <- i + 1 else - arga[idx] <- args[i] + ":" + args[i+1] + arga[idx] <- args[i] + ":" + args[i + 1] i <- i + 2 + idx <- idx + 1 + Array.toList arga[0 .. (idx - 1)] // OptionBlock: QA options //------------------------ let testingAndQAFlags _tcConfigB = - [ - CompilerOption - ("dumpAllCommandLineOptions", tagNone, - OptionHelp(fun blocks -> DumpCompilerOptionBlocks blocks), - None, None) // "Command line options") - ] - + [ + CompilerOption("dumpAllCommandLineOptions", tagNone, OptionHelp(fun blocks -> DumpCompilerOptionBlocks blocks), None, None) // "Command line options") + ] // Core compiler options, overview //-------------------------------- @@ -1605,64 +2129,89 @@ let testingAndQAFlags _tcConfigB = /// The core/common options used by fsc.exe. [not currently extended by fsc.fs]. let GetCoreFscCompilerOptions (tcConfigB: TcConfigBuilder) = - [ PublicOptions(FSComp.SR.optsHelpBannerOutputFiles(), outputFileFlagsFsc tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerInputFiles(), inputFileFlagsFsc tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerResources(), resourcesFlagsFsc tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerCodeGen(), codeGenerationFlags false tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerErrsAndWarns(), errorsAndWarningsFlags tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerLanguage(), languageFlags tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerMisc(), miscFlagsFsc tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerAdvanced(), advancedFlagsFsc tcConfigB) - PrivateOptions(List.concat [ internalFlags tcConfigB - abbreviatedFlagsFsc tcConfigB - deprecatedFlagsFsc tcConfigB - testingAndQAFlags tcConfigB]) - ] + [ + PublicOptions(FSComp.SR.optsHelpBannerOutputFiles (), outputFileFlagsFsc tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerInputFiles (), inputFileFlagsFsc tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerResources (), resourcesFlagsFsc tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerCodeGen (), codeGenerationFlags false tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerErrsAndWarns (), errorsAndWarningsFlags tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerLanguage (), languageFlags tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerMisc (), miscFlagsFsc tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerAdvanced (), advancedFlagsFsc tcConfigB) + PrivateOptions( + List.concat + [ + internalFlags tcConfigB + abbreviatedFlagsFsc tcConfigB + deprecatedFlagsFsc tcConfigB + testingAndQAFlags tcConfigB + ] + ) + ] /// The core/common options used by the F# VS Language Service. /// Filter out OptionHelp which does printing then exit. This is not wanted in the context of VS!! -let GetCoreServiceCompilerOptions (tcConfigB:TcConfigBuilder) = - let isHelpOption = function CompilerOption(_, _, OptionHelp _, _, _) -> true | _ -> false - List.map (FilterCompilerOptionBlock (isHelpOption >> not)) (GetCoreFscCompilerOptions tcConfigB) +let GetCoreServiceCompilerOptions (tcConfigB: TcConfigBuilder) = + let isHelpOption = + function + | CompilerOption (_, _, OptionHelp _, _, _) -> true + | _ -> false + + List.map (FilterCompilerOptionBlock(isHelpOption >> not)) (GetCoreFscCompilerOptions tcConfigB) /// The core/common options used by fsi.exe. [note, some additional options are added in fsi.fs]. let GetCoreFsiCompilerOptions (tcConfigB: TcConfigBuilder) = - [ PublicOptions(FSComp.SR.optsHelpBannerOutputFiles(), outputFileFlagsFsi tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerInputFiles(), inputFileFlagsFsi tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerResources(), resourcesFlagsFsi tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerCodeGen(), codeGenerationFlags true tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerErrsAndWarns(), errorsAndWarningsFlags tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerLanguage(), languageFlags tcConfigB) - // Note: no HTML block for fsi.exe - PublicOptions(FSComp.SR.optsHelpBannerMisc(), miscFlagsFsi tcConfigB) - PublicOptions(FSComp.SR.optsHelpBannerAdvanced(), advancedFlagsFsi tcConfigB) - PrivateOptions(List.concat [ internalFlags tcConfigB - abbreviatedFlagsFsi tcConfigB - deprecatedFlagsFsi tcConfigB - testingAndQAFlags tcConfigB]) - ] - -let ApplyCommandLineArgs(tcConfigB: TcConfigBuilder, sourceFiles: string list, argv) = + [ + PublicOptions(FSComp.SR.optsHelpBannerOutputFiles (), outputFileFlagsFsi tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerInputFiles (), inputFileFlagsFsi tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerResources (), resourcesFlagsFsi tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerCodeGen (), codeGenerationFlags true tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerErrsAndWarns (), errorsAndWarningsFlags tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerLanguage (), languageFlags tcConfigB) + // Note: no HTML block for fsi.exe + PublicOptions(FSComp.SR.optsHelpBannerMisc (), miscFlagsFsi tcConfigB) + PublicOptions(FSComp.SR.optsHelpBannerAdvanced (), advancedFlagsFsi tcConfigB) + PrivateOptions( + List.concat + [ + internalFlags tcConfigB + abbreviatedFlagsFsi tcConfigB + deprecatedFlagsFsi tcConfigB + testingAndQAFlags tcConfigB + ] + ) + ] + +let ApplyCommandLineArgs (tcConfigB: TcConfigBuilder, sourceFiles: string list, argv) = try let sourceFilesAcc = ResizeArray sourceFiles - let collect name = if not (FileSystemUtils.isDll name) then sourceFilesAcc.Add name + + let collect name = + if not (FileSystemUtils.isDll name) then + sourceFilesAcc.Add name + ParseCompilerOptions(collect, GetCoreServiceCompilerOptions tcConfigB, argv) ResizeArray.toList sourceFilesAcc with e -> errorRecovery e range0 sourceFiles - //---------------------------------------------------------------------------- // PrintWholeAssemblyImplementation //---------------------------------------------------------------------------- let mutable showTermFileCount = 0 -let PrintWholeAssemblyImplementation g (tcConfig:TcConfig) outfile header expr = + +let PrintWholeAssemblyImplementation g (tcConfig: TcConfig) outfile header expr = if tcConfig.showTerms then if tcConfig.writeTermsToFiles then let fileName = outfile + ".terms" - use f = FileSystem.OpenFileForWriteShim(fileName + "-" + string showTermFileCount + "-" + header, FileMode.Create).GetWriter() + + use f = + FileSystem + .OpenFileForWriteShim(fileName + "-" + string showTermFileCount + "-" + header, FileMode.Create) + .GetWriter() + showTermFileCount <- showTermFileCount + 1 LayoutRender.outL f (Display.squashTo 192 (DebugPrint.implFilesL g expr)) else @@ -1676,7 +2225,8 @@ let PrintWholeAssemblyImplementation g (tcConfig:TcConfig) outfile header expr = let mutable tPrev = None let mutable nPrev = None -let ReportTime (tcConfig:TcConfig) descr = + +let ReportTime (tcConfig: TcConfig) descr = match nPrev with | None -> () @@ -1686,87 +2236,105 @@ let ReportTime (tcConfig:TcConfig) descr = Console.ReadLine() |> ignore // Intentionally putting this right after the pause so a debugger can be attached. match tcConfig.simulateException with - | Some("fsc-oom") -> raise(OutOfMemoryException()) - | Some("fsc-an") -> raise(ArgumentNullException("simulated")) - | Some("fsc-invop") -> raise(InvalidOperationException()) - | Some("fsc-av") -> raise(AccessViolationException()) - | Some("fsc-aor") -> raise(ArgumentOutOfRangeException()) - | Some("fsc-dv0") -> raise(DivideByZeroException()) - | Some("fsc-nfn") -> raise(NotFiniteNumberException()) - | Some("fsc-oe") -> raise(OverflowException()) - | Some("fsc-atmm") -> raise(ArrayTypeMismatchException()) - | Some("fsc-bif") -> raise(BadImageFormatException()) - | Some("fsc-knf") -> raise(System.Collections.Generic.KeyNotFoundException()) - | Some("fsc-ior") -> raise(IndexOutOfRangeException()) - | Some("fsc-ic") -> raise(InvalidCastException()) - | Some("fsc-ip") -> raise(InvalidProgramException()) - | Some("fsc-ma") -> raise(MemberAccessException()) - | Some("fsc-ni") -> raise(NotImplementedException()) - | Some("fsc-nr") -> raise(NullReferenceException()) - | Some("fsc-oc") -> raise(OperationCanceledException()) - | Some("fsc-fail") -> failwith "simulated" + | Some ("fsc-oom") -> raise (OutOfMemoryException()) + | Some ("fsc-an") -> raise (ArgumentNullException("simulated")) + | Some ("fsc-invop") -> raise (InvalidOperationException()) + | Some ("fsc-av") -> raise (AccessViolationException()) + | Some ("fsc-aor") -> raise (ArgumentOutOfRangeException()) + | Some ("fsc-dv0") -> raise (DivideByZeroException()) + | Some ("fsc-nfn") -> raise (NotFiniteNumberException()) + | Some ("fsc-oe") -> raise (OverflowException()) + | Some ("fsc-atmm") -> raise (ArrayTypeMismatchException()) + | Some ("fsc-bif") -> raise (BadImageFormatException()) + | Some ("fsc-knf") -> raise (System.Collections.Generic.KeyNotFoundException()) + | Some ("fsc-ior") -> raise (IndexOutOfRangeException()) + | Some ("fsc-ic") -> raise (InvalidCastException()) + | Some ("fsc-ip") -> raise (InvalidProgramException()) + | Some ("fsc-ma") -> raise (MemberAccessException()) + | Some ("fsc-ni") -> raise (NotImplementedException()) + | Some ("fsc-nr") -> raise (NullReferenceException()) + | Some ("fsc-oc") -> raise (OperationCanceledException()) + | Some ("fsc-fail") -> failwith "simulated" | _ -> () - - - if (tcConfig.showTimes || verbose) then // Note that timing calls are relatively expensive on the startup path so we don't // make this call unless showTimes has been turned on. - let timeNow = System.Diagnostics.Process.GetCurrentProcess().UserProcessorTime.TotalSeconds + let timeNow = + System.Diagnostics.Process.GetCurrentProcess().UserProcessorTime.TotalSeconds + let maxGen = GC.MaxGeneration - let gcNow = [| for i in 0 .. maxGen -> GC.CollectionCount i |] + let gcNow = [| for i in 0..maxGen -> GC.CollectionCount i |] let ptime = System.Diagnostics.Process.GetCurrentProcess() - let wsNow = ptime.WorkingSet64/1000000L + let wsNow = ptime.WorkingSet64 / 1000000L match tPrev, nPrev with - | Some (timePrev, gcPrev:int []), Some prevDescr -> - let spanGC = [| for i in 0 .. maxGen -> GC.CollectionCount i - gcPrev[i] |] - dprintf "TIME: %4.1f Delta: %4.1f Mem: %3d" - timeNow (timeNow - timePrev) - wsNow - dprintf " G0: %3d G1: %2d G2: %2d [%s]\n" - spanGC[Operators.min 0 maxGen] spanGC[Operators.min 1 maxGen] spanGC[Operators.min 2 maxGen] + | Some (timePrev, gcPrev: int[]), Some prevDescr -> + let spanGC = [| for i in 0..maxGen -> GC.CollectionCount i - gcPrev[i] |] + dprintf "TIME: %4.1f Delta: %4.1f Mem: %3d" timeNow (timeNow - timePrev) wsNow + + dprintf + " G0: %3d G1: %2d G2: %2d [%s]\n" + spanGC[Operators.min 0 maxGen] + spanGC[Operators.min 1 maxGen] + spanGC[Operators.min 2 maxGen] prevDescr | _ -> () - tPrev <- Some (timeNow, gcNow) + + tPrev <- Some(timeNow, gcNow) nPrev <- Some descr -let ignoreFailureOnMono1_1_16 f = try f() with _ -> () +let ignoreFailureOnMono1_1_16 f = + try + f () + with _ -> + () let foreBackColor () = try let c = Console.ForegroundColor // may fail, perhaps on Mac, and maybe ForegroundColor is Black let b = Console.BackgroundColor // may fail, perhaps on Mac, and maybe BackgroundColor is White - Some (c, b) - with - e -> None + Some(c, b) + with e -> + None let DoWithColor newColor f = - match enableConsoleColoring, foreBackColor() with + match enableConsoleColoring, foreBackColor () with | false, _ | true, None -> // could not get console colours, so no attempt to change colours, can not set them back - f() + f () | true, Some (c, _) -> try ignoreFailureOnMono1_1_16 (fun () -> Console.ForegroundColor <- newColor) - f() + f () finally ignoreFailureOnMono1_1_16 (fun () -> Console.ForegroundColor <- c) let DoWithDiagnosticColor severity f = - match foreBackColor() with - | None -> f() + match foreBackColor () with + | None -> f () | Some (_, backColor) -> - let infoColor = if backColor = ConsoleColor.White then ConsoleColor.Blue else ConsoleColor.Green - let warnColor = if backColor = ConsoleColor.White then ConsoleColor.DarkBlue else ConsoleColor.Cyan + let infoColor = + if backColor = ConsoleColor.White then + ConsoleColor.Blue + else + ConsoleColor.Green + + let warnColor = + if backColor = ConsoleColor.White then + ConsoleColor.DarkBlue + else + ConsoleColor.Cyan + let errorColor = ConsoleColor.Red + let color = match severity with | FSharpDiagnosticSeverity.Error -> errorColor | FSharpDiagnosticSeverity.Warning -> warnColor | _ -> infoColor + DoWithColor color f diff --git a/src/Compiler/Driver/CreateILModule.fs b/src/Compiler/Driver/CreateILModule.fs index 5cb00a7f215..9039453478c 100644 --- a/src/Compiler/Driver/CreateILModule.fs +++ b/src/Compiler/Driver/CreateILModule.fs @@ -31,31 +31,32 @@ module AttributeHelpers = /// Try to find an attribute that takes a string argument let TryFindStringAttribute (g: TcGlobals) attrib attribs = - match g.TryFindSysAttrib attrib with - | None -> None - | Some attribRef -> - match TryFindFSharpAttribute g attribRef attribs with - | Some (Attrib(_, _, [ AttribStringArg s ], _, _, _, _)) -> Some s - | _ -> None + match g.TryFindSysAttrib attrib with + | None -> None + | Some attribRef -> + match TryFindFSharpAttribute g attribRef attribs with + | Some (Attrib (_, _, [ AttribStringArg s ], _, _, _, _)) -> Some s + | _ -> None let TryFindIntAttribute (g: TcGlobals) attrib attribs = - match g.TryFindSysAttrib attrib with - | None -> None - | Some attribRef -> - match TryFindFSharpAttribute g attribRef attribs with - | Some (Attrib(_, _, [ AttribInt32Arg i ], _, _, _, _)) -> Some i - | _ -> None + match g.TryFindSysAttrib attrib with + | None -> None + | Some attribRef -> + match TryFindFSharpAttribute g attribRef attribs with + | Some (Attrib (_, _, [ AttribInt32Arg i ], _, _, _, _)) -> Some i + | _ -> None let TryFindBoolAttribute (g: TcGlobals) attrib attribs = - match g.TryFindSysAttrib attrib with - | None -> None - | Some attribRef -> - match TryFindFSharpAttribute g attribRef attribs with - | Some (Attrib(_, _, [ AttribBoolArg p ], _, _, _, _)) -> Some p - | _ -> None + match g.TryFindSysAttrib attrib with + | None -> None + | Some attribRef -> + match TryFindFSharpAttribute g attribRef attribs with + | Some (Attrib (_, _, [ AttribBoolArg p ], _, _, _, _)) -> Some p + | _ -> None let (|ILVersion|_|) (versionString: string) = - try Some (parseILVersion versionString) + try + Some(parseILVersion versionString) with e -> None @@ -67,20 +68,25 @@ module AttributeHelpers = type StrongNameSigningInfo = StrongNameSigningInfo of delaysign: bool * publicsign: bool * signer: string option * container: string option /// Validate the attributes and configuration settings used to perform strong-name signing -let ValidateKeySigningAttributes (tcConfig : TcConfig, tcGlobals, topAttrs) = - let delaySignAttrib = AttributeHelpers.TryFindBoolAttribute tcGlobals "System.Reflection.AssemblyDelaySignAttribute" topAttrs.assemblyAttrs - let signerAttrib = AttributeHelpers.TryFindStringAttribute tcGlobals "System.Reflection.AssemblyKeyFileAttribute" topAttrs.assemblyAttrs - let containerAttrib = AttributeHelpers.TryFindStringAttribute tcGlobals "System.Reflection.AssemblyKeyNameAttribute" topAttrs.assemblyAttrs +let ValidateKeySigningAttributes (tcConfig: TcConfig, tcGlobals, topAttrs) = + let delaySignAttrib = + AttributeHelpers.TryFindBoolAttribute tcGlobals "System.Reflection.AssemblyDelaySignAttribute" topAttrs.assemblyAttrs + + let signerAttrib = + AttributeHelpers.TryFindStringAttribute tcGlobals "System.Reflection.AssemblyKeyFileAttribute" topAttrs.assemblyAttrs + + let containerAttrib = + AttributeHelpers.TryFindStringAttribute tcGlobals "System.Reflection.AssemblyKeyNameAttribute" topAttrs.assemblyAttrs // if delaySign is set via an attribute, validate that it wasn't set via an option let delaysign = match delaySignAttrib with | Some delaysign -> - if tcConfig.delaysign then - warning(Error(FSComp.SR.fscDelaySignWarning(), rangeCmdArgs)) - tcConfig.delaysign - else - delaysign + if tcConfig.delaysign then + warning (Error(FSComp.SR.fscDelaySignWarning (), rangeCmdArgs)) + tcConfig.delaysign + else + delaysign | _ -> tcConfig.delaysign // if signer is set via an attribute, validate that it wasn't set via an option @@ -88,7 +94,7 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig, tcGlobals, topAttrs) = match signerAttrib with | Some signer -> if tcConfig.signer.IsSome && tcConfig.signer <> Some signer then - warning(Error(FSComp.SR.fscKeyFileWarning(), rangeCmdArgs)) + warning (Error(FSComp.SR.fscKeyFileWarning (), rangeCmdArgs)) tcConfig.signer else Some signer @@ -101,35 +107,35 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig, tcGlobals, topAttrs) = match containerAttrib with | Some container -> if not FSharpEnvironment.isRunningOnCoreClr then - warning(Error(FSComp.SR.containerDeprecated(), rangeCmdArgs)) + warning (Error(FSComp.SR.containerDeprecated (), rangeCmdArgs)) + if tcConfig.container.IsSome && tcConfig.container <> Some container then - warning(Error(FSComp.SR.fscKeyNameWarning(), rangeCmdArgs)) - tcConfig.container + warning (Error(FSComp.SR.fscKeyNameWarning (), rangeCmdArgs)) + tcConfig.container else - Some container + Some container | None -> tcConfig.container - StrongNameSigningInfo (delaysign, tcConfig.publicsign, signer, container) + StrongNameSigningInfo(delaysign, tcConfig.publicsign, signer, container) /// Get the object used to perform strong-name signing let GetStrongNameSigner signingInfo = - let (StrongNameSigningInfo(delaysign, publicsign, signer, container)) = signingInfo + let (StrongNameSigningInfo (delaysign, publicsign, signer, container)) = signingInfo // REVIEW: favor the container over the key file - C# appears to do this match container with - | Some container -> - Some (ILStrongNameSigner.OpenKeyContainer container) + | Some container -> Some(ILStrongNameSigner.OpenKeyContainer container) | None -> match signer with | None -> None | Some s -> try if publicsign || delaysign then - Some (ILStrongNameSigner.OpenPublicKeyOptions s publicsign) + Some(ILStrongNameSigner.OpenPublicKeyOptions s publicsign) else - Some (ILStrongNameSigner.OpenKeyPairFile s) + Some(ILStrongNameSigner.OpenKeyPairFile s) with _ -> // Note :: don't use errorR here since we really want to fail and not produce a binary - error(Error(FSComp.SR.fscKeyFileCouldNotBeOpened s, rangeCmdArgs)) + error (Error(FSComp.SR.fscKeyFileCouldNotBeOpened s, rangeCmdArgs)) //---------------------------------------------------------------------------- // Building the contents of the finalized IL module @@ -138,65 +144,87 @@ let GetStrongNameSigner signingInfo = module MainModuleBuilder = let injectedCompatTypes = - set [ "System.Tuple`1" - "System.Tuple`2" - "System.Tuple`3" - "System.Tuple`4" - "System.Tuple`5" - "System.Tuple`6" - "System.Tuple`7" - "System.Tuple`8" - "System.ITuple" - "System.Tuple" - "System.Collections.IStructuralComparable" - "System.Collections.IStructuralEquatable" ] + set + [ + "System.Tuple`1" + "System.Tuple`2" + "System.Tuple`3" + "System.Tuple`4" + "System.Tuple`5" + "System.Tuple`6" + "System.Tuple`7" + "System.Tuple`8" + "System.ITuple" + "System.Tuple" + "System.Collections.IStructuralComparable" + "System.Collections.IStructuralEquatable" + ] let typesForwardedToMscorlib = - set [ "System.AggregateException" - "System.Threading.CancellationTokenRegistration" - "System.Threading.CancellationToken" - "System.Threading.CancellationTokenSource" - "System.Lazy`1" - "System.IObservable`1" - "System.IObserver`1" ] - - let typesForwardedToSystemNumerics = - set [ "System.Numerics.BigInteger" ] + set + [ + "System.AggregateException" + "System.Threading.CancellationTokenRegistration" + "System.Threading.CancellationToken" + "System.Threading.CancellationTokenSource" + "System.Lazy`1" + "System.IObservable`1" + "System.IObserver`1" + ] + + let typesForwardedToSystemNumerics = set [ "System.Numerics.BigInteger" ] let createMscorlibExportList (tcGlobals: TcGlobals) = - // We want to write forwarders out for all injected types except for System.ITuple, which is internal - // Forwarding System.ITuple will cause FxCop failures on 4.0 - Set.union (Set.filter (fun t -> t <> "System.ITuple") injectedCompatTypes) typesForwardedToMscorlib |> - Seq.map (fun t -> mkTypeForwarder tcGlobals.ilg.primaryAssemblyScopeRef t (mkILNestedExportedTypes List.empty) (mkILCustomAttrs List.empty) ILTypeDefAccess.Public ) - |> Seq.toList + // We want to write forwarders out for all injected types except for System.ITuple, which is internal + // Forwarding System.ITuple will cause FxCop failures on 4.0 + Set.union (Set.filter (fun t -> t <> "System.ITuple") injectedCompatTypes) typesForwardedToMscorlib + |> Seq.map (fun t -> + mkTypeForwarder + tcGlobals.ilg.primaryAssemblyScopeRef + t + (mkILNestedExportedTypes List.empty) + (mkILCustomAttrs List.empty) + ILTypeDefAccess.Public) + |> Seq.toList let createSystemNumericsExportList (tcConfig: TcConfig) (tcImports: TcImports) = let refNumericsDllName = - if (tcConfig.primaryAssembly.Name = "mscorlib") then "System.Numerics" - else "System.Runtime.Numerics" + if (tcConfig.primaryAssembly.Name = "mscorlib") then + "System.Numerics" + else + "System.Runtime.Numerics" + let numericsAssemblyRef = - match tcImports.GetImportedAssemblies() |> List.tryFind(fun a -> a.FSharpViewOfMetadata.AssemblyName = refNumericsDllName) with + match tcImports.GetImportedAssemblies() + |> List.tryFind (fun a -> a.FSharpViewOfMetadata.AssemblyName = refNumericsDllName) + with | Some asm -> match asm.ILScopeRef with | ILScopeRef.Assembly aref -> Some aref | _ -> None | None -> None + match numericsAssemblyRef with | Some aref -> - let systemNumericsAssemblyRef = ILAssemblyRef.Create(refNumericsDllName, aref.Hash, aref.PublicKey, aref.Retargetable, aref.Version, aref.Locale) - typesForwardedToSystemNumerics |> - Seq.map (fun t -> - { ScopeRef = ILScopeRef.Assembly systemNumericsAssemblyRef - Name = t - Attributes = enum(0x00200000) ||| TypeAttributes.Public - Nested = mkILNestedExportedTypes [] - CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx }) |> - Seq.toList + let systemNumericsAssemblyRef = + ILAssemblyRef.Create(refNumericsDllName, aref.Hash, aref.PublicKey, aref.Retargetable, aref.Version, aref.Locale) + + typesForwardedToSystemNumerics + |> Seq.map (fun t -> + { + ScopeRef = ILScopeRef.Assembly systemNumericsAssemblyRef + Name = t + Attributes = enum (0x00200000) ||| TypeAttributes.Public + Nested = mkILNestedExportedTypes [] + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + }) + |> Seq.toList | None -> [] let ComputeILFileVersion findStringAttr (assemblyVersion: ILVersionInfo) = let attrName = "System.Reflection.AssemblyFileVersionAttribute" + match findStringAttr attrName with | None -> assemblyVersion | Some (AttributeHelpers.ILVersion v) -> v @@ -206,69 +234,108 @@ module MainModuleBuilder = let ComputeProductVersion findStringAttr (fileVersion: ILVersionInfo) = let attrName = "System.Reflection.AssemblyInformationalVersionAttribute" - let toDotted (version: ILVersionInfo) = sprintf "%d.%d.%d.%d" version.Major version.Minor version.Build version.Revision + + let toDotted (version: ILVersionInfo) = + sprintf "%d.%d.%d.%d" version.Major version.Minor version.Build version.Revision + match findStringAttr attrName with - | None | Some "" -> fileVersion |> toDotted + | None + | Some "" -> fileVersion |> toDotted | Some (AttributeHelpers.ILVersion v) -> v |> toDotted | Some v -> // Warning will be reported by CheckExpressions.fs v let ConvertProductVersionToILVersionInfo (version: string) : ILVersionInfo = - let parseOrZero i (v:string) = + let parseOrZero i (v: string) = let v = // When i = 3 then this is the 4th part of the version. The last part of the version can be trailed by any characters so we trim them off if i <> 3 then v else ((false, ""), v) - ||> Seq.fold(fun (finished, v) c -> + ||> Seq.fold (fun (finished, v) c -> match finished with | false when Char.IsDigit(c) -> false, v + c.ToString() | _ -> true, v) |> snd + match UInt16.TryParse v with | true, i -> i | false, _ -> 0us + let validParts = - version.Split('.') - |> Array.mapi(fun i v -> parseOrZero i v) - |> Seq.toList - match validParts @ [0us; 0us; 0us; 0us] with + version.Split('.') |> Array.mapi (fun i v -> parseOrZero i v) |> Seq.toList + + match validParts @ [ 0us; 0us; 0us; 0us ] with | major :: minor :: build :: rev :: _ -> ILVersionInfo(major, minor, build, rev) | x -> failwithf "error converting product version '%s' to binary, tried '%A' " version x - let CreateMainModule - (ctok, tcConfig: TcConfig, tcGlobals, tcImports: TcImports, - pdbfile, assemblyName, outfile, topAttrs, - sigDataAttributes: ILAttribute list, sigDataResources: ILResource list, optDataResources: ILResource list, - codegenResults, assemVerFromAttrib, metadataVersion, secDecls) = + ( + ctok, + tcConfig: TcConfig, + tcGlobals, + tcImports: TcImports, + pdbfile, + assemblyName, + outfile, + topAttrs, + sigDataAttributes: ILAttribute list, + sigDataResources: ILResource list, + optDataResources: ILResource list, + codegenResults, + assemVerFromAttrib, + metadataVersion, + secDecls + ) = RequireCompilationThread ctok + let ilTypeDefs = //let topTypeDef = mkILTypeDefForGlobalFunctions tcGlobals.ilg (mkILMethods [], emptyILFields) mkILTypeDefs codegenResults.ilTypeDefs let mainModule = - let hashAlg = AttributeHelpers.TryFindIntAttribute tcGlobals "System.Reflection.AssemblyAlgorithmIdAttribute" topAttrs.assemblyAttrs - let locale = AttributeHelpers.TryFindStringAttribute tcGlobals "System.Reflection.AssemblyCultureAttribute" topAttrs.assemblyAttrs - let flags = match AttributeHelpers.TryFindIntAttribute tcGlobals "System.Reflection.AssemblyFlagsAttribute" topAttrs.assemblyAttrs with | Some f -> f | _ -> 0x0 + let hashAlg = + AttributeHelpers.TryFindIntAttribute tcGlobals "System.Reflection.AssemblyAlgorithmIdAttribute" topAttrs.assemblyAttrs + + let locale = + AttributeHelpers.TryFindStringAttribute tcGlobals "System.Reflection.AssemblyCultureAttribute" topAttrs.assemblyAttrs + + let flags = + match AttributeHelpers.TryFindIntAttribute tcGlobals "System.Reflection.AssemblyFlagsAttribute" topAttrs.assemblyAttrs with + | Some f -> f + | _ -> 0x0 // You're only allowed to set a locale if the assembly is a library if (locale <> None && locale.Value <> "") && tcConfig.target <> CompilerTarget.Dll then - error(Error(FSComp.SR.fscAssemblyCultureAttributeError(), rangeCmdArgs)) + error (Error(FSComp.SR.fscAssemblyCultureAttributeError (), rangeCmdArgs)) // Add the type forwarders to any .NET DLL post-.NET-2.0, to give binary compatibility let exportedTypesList = if tcConfig.compilingFSharpCore then - List.append (createMscorlibExportList tcGlobals) (createSystemNumericsExportList tcConfig tcImports) + List.append (createMscorlibExportList tcGlobals) (createSystemNumericsExportList tcConfig tcImports) else [] let ilModuleName = GetGeneratedILModuleName tcConfig.target assemblyName - let isDLL = (tcConfig.target = CompilerTarget.Dll || tcConfig.target = CompilerTarget.Module) - mkILSimpleModule assemblyName ilModuleName isDLL tcConfig.subsystemVersion tcConfig.useHighEntropyVA ilTypeDefs hashAlg locale flags (mkILExportedTypes exportedTypesList) metadataVersion + + let isDLL = + (tcConfig.target = CompilerTarget.Dll || tcConfig.target = CompilerTarget.Module) + + mkILSimpleModule + assemblyName + ilModuleName + isDLL + tcConfig.subsystemVersion + tcConfig.useHighEntropyVA + ilTypeDefs + hashAlg + locale + flags + (mkILExportedTypes exportedTypesList) + metadataVersion let disableJitOptimizations = not tcConfig.optSettings.JitOptimizationsEnabled @@ -277,74 +344,130 @@ module MainModuleBuilder = let reflectedDefinitionAttrs, reflectedDefinitionResources = codegenResults.quotationResourceInfo |> List.map (fun (referencedTypeDefs, reflectedDefinitionBytes) -> - let reflectedDefinitionResourceName = QuotationPickler.SerializedReflectedDefinitionsResourceNameBase+"-"+assemblyName+"-"+string(newUnique())+"-"+string(hash reflectedDefinitionBytes) + let reflectedDefinitionResourceName = + QuotationPickler.SerializedReflectedDefinitionsResourceNameBase + + "-" + + assemblyName + + "-" + + string (newUnique ()) + + "-" + + string (hash reflectedDefinitionBytes) + let reflectedDefinitionAttrs = - let qf = QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat tcGlobals + let qf = + QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat tcGlobals + if qf.SupportsDeserializeEx then - [ mkCompilationMappingAttrForQuotationResource tcGlobals (reflectedDefinitionResourceName, referencedTypeDefs) ] + [ + mkCompilationMappingAttrForQuotationResource tcGlobals (reflectedDefinitionResourceName, referencedTypeDefs) + ] else - [ ] + [] + let reflectedDefinitionResource = - { Name=reflectedDefinitionResourceName - Location = ILResourceLocation.Local(ByteStorage.FromByteArray(reflectedDefinitionBytes)) - Access= ILResourceAccess.Public - CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } + { + Name = reflectedDefinitionResourceName + Location = ILResourceLocation.Local(ByteStorage.FromByteArray(reflectedDefinitionBytes)) + Access = ILResourceAccess.Public + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } + reflectedDefinitionAttrs, reflectedDefinitionResource) |> List.unzip |> (fun (attrs, resource) -> List.concat attrs, resource) let manifestAttrs = mkILCustomAttrs - [ if not tcConfig.internConstantStrings then - yield mkILCustomAttribute (tcGlobals.FindSysILTypeRef "System.Runtime.CompilerServices.CompilationRelaxationsAttribute", [tcGlobals.ilg.typ_Int32], [ILAttribElem.Int32( 8)], []) - yield! sigDataAttributes - yield! codegenResults.ilAssemAttrs - - if Option.isSome pdbfile then - yield (tcGlobals.mkDebuggableAttributeV2 (tcConfig.jitTracking, tcConfig.ignoreSymbolStoreSequencePoints, disableJitOptimizations, false (* enableEnC *) )) - yield! reflectedDefinitionAttrs ] + [ + if not tcConfig.internConstantStrings then + mkILCustomAttribute ( + tcGlobals.FindSysILTypeRef "System.Runtime.CompilerServices.CompilationRelaxationsAttribute", + [ tcGlobals.ilg.typ_Int32 ], + [ ILAttribElem.Int32(8) ], + [] + ) + yield! sigDataAttributes + yield! codegenResults.ilAssemAttrs + + if Option.isSome pdbfile then + tcGlobals.mkDebuggableAttributeV2 ( + tcConfig.jitTracking, + tcConfig.ignoreSymbolStoreSequencePoints, + disableJitOptimizations, + false (* enableEnC *) + ) + yield! reflectedDefinitionAttrs + ] // Make the manifest of the assembly let manifest = - if tcConfig.target = CompilerTarget.Module then None else - let man = mainModule.ManifestOfAssembly - let ver = - match assemVerFromAttrib with - | None -> tcVersion - | Some v -> v - Some { man with Version= Some ver - CustomAttrsStored = storeILCustomAttrs manifestAttrs - DisableJitOptimizations=disableJitOptimizations - JitTracking= tcConfig.jitTracking - IgnoreSymbolStoreSequencePoints = tcConfig.ignoreSymbolStoreSequencePoints - SecurityDeclsStored=storeILSecurityDecls secDecls } + if tcConfig.target = CompilerTarget.Module then + None + else + let man = mainModule.ManifestOfAssembly + + let ver = + match assemVerFromAttrib with + | None -> tcVersion + | Some v -> v + + Some + { man with + Version = Some ver + CustomAttrsStored = storeILCustomAttrs manifestAttrs + DisableJitOptimizations = disableJitOptimizations + JitTracking = tcConfig.jitTracking + IgnoreSymbolStoreSequencePoints = tcConfig.ignoreSymbolStoreSequencePoints + SecurityDeclsStored = storeILSecurityDecls secDecls + } let resources = - mkILResources - [ for file in tcConfig.embedResources do - let name, bytes, pub = - let file, name, pub = TcConfigBuilder.SplitCommandLineResourceInfo file - let file = tcConfig.ResolveSourceFile(rangeStartup, file, tcConfig.implicitIncludeDir) - let bytes = FileSystem.OpenFileForReadShim(file).ReadAllBytes() - name, bytes, pub - yield { Name=name - // TODO: We probably can directly convert ByteMemory to ByteStorage, without reading all bytes. - Location=ILResourceLocation.Local(ByteStorage.FromByteArray(bytes)) - Access=pub - CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } - - yield! reflectedDefinitionResources - yield! sigDataResources - yield! optDataResources - for ri in tcConfig.linkResources do - let file, name, pub = TcConfigBuilder.SplitCommandLineResourceInfo ri - yield { Name=name - Location=ILResourceLocation.File(ILModuleRef.Create(name=file, hasMetadata=false, hash=Some (sha1HashBytes (FileSystem.OpenFileForReadShim(file).ReadAllBytes()))), 0) - Access=pub - CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } ] + mkILResources + [ + for file in tcConfig.embedResources do + let name, bytes, pub = + let file, name, pub = TcConfigBuilder.SplitCommandLineResourceInfo file + + let file = + tcConfig.ResolveSourceFile(rangeStartup, file, tcConfig.implicitIncludeDir) + + let bytes = FileSystem.OpenFileForReadShim(file).ReadAllBytes() + name, bytes, pub + + { + Name = name + // TODO: We probably can directly convert ByteMemory to ByteStorage, without reading all bytes. + Location = ILResourceLocation.Local(ByteStorage.FromByteArray(bytes)) + Access = pub + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } + + yield! reflectedDefinitionResources + yield! sigDataResources + yield! optDataResources + for ri in tcConfig.linkResources do + let file, name, pub = TcConfigBuilder.SplitCommandLineResourceInfo ri + + let location = + ILResourceLocation.File( + ILModuleRef.Create( + name = file, + hasMetadata = false, + hash = Some(sha1HashBytes (FileSystem.OpenFileForReadShim(file).ReadAllBytes())) + ), + 0 + ) + + { + Name = name + Location = location + Access = pub + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } + ] let assemblyVersion = match tcConfig.version with @@ -362,7 +485,7 @@ module MainModuleBuilder = | Some assemblyVersion -> let FindAttribute key attrib = match findAttribute attrib with - | Some text -> [(key, text)] + | Some text -> [ (key, text) ] | _ -> [] let fileVersionInfo = ComputeILFileVersion findAttribute assemblyVersion @@ -370,26 +493,33 @@ module MainModuleBuilder = let productVersionString = ComputeProductVersion findAttribute fileVersionInfo let stringFileInfo = - // 000004b0: - // Specifies an 8-digit hexadecimal number stored as a Unicode string. The - // four most significant digits represent the language identifier. The four least - // significant digits represent the code page for which the data is formatted. - // Each Microsoft Standard Language identifier contains two parts: the low-order 10 bits - // specify the major language, and the high-order 6 bits specify the sublanguage. - // For a table of valid identifiers see Language Identifiers. // - // see e.g. http://msdn.microsoft.com/en-us/library/aa912040.aspx 0000 is neutral and 04b0(hex)=1252(dec) is the code page. - [ ("000004b0", [ yield ("Assembly Version", (sprintf "%d.%d.%d.%d" assemblyVersion.Major assemblyVersion.Minor assemblyVersion.Build assemblyVersion.Revision)) - yield ("FileVersion", (sprintf "%d.%d.%d.%d" fileVersionInfo.Major fileVersionInfo.Minor fileVersionInfo.Build fileVersionInfo.Revision)) - yield ("ProductVersion", productVersionString) - match tcConfig.outputFile with - | Some f -> yield ("OriginalFilename", Path.GetFileName f) - | None -> () - yield! FindAttribute "Comments" "System.Reflection.AssemblyDescriptionAttribute" - yield! FindAttribute "FileDescription" "System.Reflection.AssemblyTitleAttribute" - yield! FindAttribute "ProductName" "System.Reflection.AssemblyProductAttribute" - yield! FindAttribute "CompanyName" "System.Reflection.AssemblyCompanyAttribute" - yield! FindAttribute "LegalCopyright" "System.Reflection.AssemblyCopyrightAttribute" - yield! FindAttribute "LegalTrademarks" "System.Reflection.AssemblyTrademarkAttribute" ]) ] + // 000004b0: + // Specifies an 8-digit hexadecimal number stored as a Unicode string. The + // four most significant digits represent the language identifier. The four least + // significant digits represent the code page for which the data is formatted. + // Each Microsoft Standard Language identifier contains two parts: the low-order 10 bits + // specify the major language, and the high-order 6 bits specify the sublanguage. + // For a table of valid identifiers see Language Identifiers. // + // see e.g. http://msdn.microsoft.com/en-us/library/aa912040.aspx 0000 is neutral and 04b0(hex)=1252(dec) is the code page. + [ + ("000004b0", + [ + ("Assembly Version", + $"%d{assemblyVersion.Major}.%d{assemblyVersion.Minor}.%d{assemblyVersion.Build}.%d{assemblyVersion.Revision}") + ("FileVersion", + $"%d{fileVersionInfo.Major}.%d{fileVersionInfo.Minor}.%d{fileVersionInfo.Build}.%d{fileVersionInfo.Revision}") + ("ProductVersion", productVersionString) + match tcConfig.outputFile with + | Some f -> ("OriginalFilename", Path.GetFileName f) + | None -> () + yield! FindAttribute "Comments" "System.Reflection.AssemblyDescriptionAttribute" + yield! FindAttribute "FileDescription" "System.Reflection.AssemblyTitleAttribute" + yield! FindAttribute "ProductName" "System.Reflection.AssemblyProductAttribute" + yield! FindAttribute "CompanyName" "System.Reflection.AssemblyCompanyAttribute" + yield! FindAttribute "LegalCopyright" "System.Reflection.AssemblyCopyrightAttribute" + yield! FindAttribute "LegalTrademarks" "System.Reflection.AssemblyTrademarkAttribute" + ]) + ] // These entries listed in the MSDN documentation as "standard" string entries are not yet settable @@ -421,7 +551,7 @@ module MainModuleBuilder = // Either high-order or low-order word can be zero, indicating that // the file is language or code page independent. If the Var structure is // omitted, the file will be interpreted as both language and code page independent. " - let varFileInfo = [ (0x0, 0x04b0) ] + let varFileInfo = [ (0x0, 0x04b0) ] let fixedFileInfo = let dwFileFlagsMask = 0x3f // REVIEW: HARDWIRED @@ -430,71 +560,127 @@ module MainModuleBuilder = let dwFileType = 0x01 // REVIEW: HARDWIRED let dwFileSubtype = 0x00 // REVIEW: HARDWIRED let lwFileDate = 0x00L // REVIEW: HARDWIRED - (fileVersionInfo, productVersionString |> ConvertProductVersionToILVersionInfo, dwFileFlagsMask, dwFileFlags, dwFileOS, dwFileType, dwFileSubtype, lwFileDate) + let ilProductVersion = productVersionString |> ConvertProductVersionToILVersionInfo + (fileVersionInfo, ilProductVersion, dwFileFlagsMask, dwFileFlags, dwFileOS, dwFileType, dwFileSubtype, lwFileDate) let vsVersionInfoResource = VersionResourceFormat.VS_VERSION_INFO_RESOURCE(fixedFileInfo, stringFileInfo, varFileInfo) let resource = - [| yield! ResFileFormat.ResFileHeader() - yield! vsVersionInfoResource |] + [| yield! ResFileFormat.ResFileHeader(); yield! vsVersionInfoResource |] [ resource ] // a user cannot specify both win32res and win32manifest - if not(tcConfig.win32manifest = "") && not(tcConfig.win32res = "") then - error(Error(FSComp.SR.fscTwoResourceManifests(), rangeCmdArgs)) + if not (tcConfig.win32manifest = "") && not (tcConfig.win32res = "") then + error (Error(FSComp.SR.fscTwoResourceManifests (), rangeCmdArgs)) let win32Manifest = // use custom manifest if provided - if not(tcConfig.win32manifest = "") then tcConfig.win32manifest + if not (tcConfig.win32manifest = "") then + tcConfig.win32manifest // don't embed a manifest if target is not an exe, if manifest is specifically excluded, if another native resource is being included, or if running on mono - elif not(tcConfig.target.IsExe) || not(tcConfig.includewin32manifest) || not(tcConfig.win32res = "") || runningOnMono then "" + elif not (tcConfig.target.IsExe) + || not (tcConfig.includewin32manifest) + || not (tcConfig.win32res = "") + || runningOnMono then + "" // otherwise, include the default manifest else - let path=Path.Combine(FSharpEnvironment.getFSharpCompilerLocation(), @"default.win32manifest") + let path = + Path.Combine(FSharpEnvironment.getFSharpCompilerLocation (), @"default.win32manifest") + if FileSystem.FileExistsShim(path) then path else let path = Path.Combine(AppContext.BaseDirectory, @"default.win32manifest") + if FileSystem.FileExistsShim(path) then path else Path.Combine(System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory(), @"default.win32manifest") let nativeResources = - [ for av in assemblyVersionResources assemblyVersion do - yield ILNativeResource.Out av - if not(tcConfig.win32res = "") then - yield ILNativeResource.Out (FileSystem.OpenFileForReadShim(tcConfig.win32res).ReadAllBytes()) - if tcConfig.includewin32manifest && not(win32Manifest = "") && not runningOnMono then - yield ILNativeResource.Out [| yield! ResFileFormat.ResFileHeader() - yield! (ManifestResourceFormat.VS_MANIFEST_RESOURCE((FileSystem.OpenFileForReadShim(win32Manifest).ReadAllBytes()), tcConfig.target = CompilerTarget.Dll)) |] - if tcConfig.win32res = "" && tcConfig.win32icon <> "" && tcConfig.target <> CompilerTarget.Dll then - use ms = new MemoryStream() - use iconStream = FileSystem.OpenFileForReadShim(tcConfig.win32icon) - Win32ResourceConversions.AppendIconToResourceStream(ms, iconStream) - yield ILNativeResource.Out [| yield! ResFileFormat.ResFileHeader() - yield! ms.ToArray() |] ] - + [ + for av in assemblyVersionResources assemblyVersion do + ILNativeResource.Out av + if not (tcConfig.win32res = "") then + ILNativeResource.Out(FileSystem.OpenFileForReadShim(tcConfig.win32res).ReadAllBytes()) + if tcConfig.includewin32manifest && not (win32Manifest = "") && not runningOnMono then + ILNativeResource.Out + [| + yield! ResFileFormat.ResFileHeader() + yield! + (ManifestResourceFormat.VS_MANIFEST_RESOURCE( + (FileSystem.OpenFileForReadShim(win32Manifest).ReadAllBytes()), + tcConfig.target = CompilerTarget.Dll + )) + |] + if tcConfig.win32res = "" + && tcConfig.win32icon <> "" + && tcConfig.target <> CompilerTarget.Dll then + use ms = new MemoryStream() + use iconStream = FileSystem.OpenFileForReadShim(tcConfig.win32icon) + Win32ResourceConversions.AppendIconToResourceStream(ms, iconStream) + ILNativeResource.Out [| yield! ResFileFormat.ResFileHeader(); yield! ms.ToArray() |] + ] + + let name = + if tcConfig.target = CompilerTarget.Module then + FileSystemUtils.fileNameOfPath outfile + else + mainModule.Name + + let imageBase = + match tcConfig.baseAddress with + | None -> 0x00400000l + | Some b -> b + + let isDLL = + (tcConfig.target = CompilerTarget.Dll || tcConfig.target = CompilerTarget.Module) + + let is32bit = + match tcConfig.platform with + | Some X86 + | Some ARM -> true + | _ -> false + + let is64bit = + match tcConfig.platform with + | Some AMD64 + | Some IA64 + | Some ARM64 -> true + | _ -> false + + let is32BitPreferred = + if tcConfig.prefer32Bit && not tcConfig.target.IsExe then + (error (Error(FSComp.SR.invalidPlatformTarget (), rangeCmdArgs))) + else + tcConfig.prefer32Bit + + let attribs = + storeILCustomAttrs ( + mkILCustomAttrs + [ + if tcConfig.target = CompilerTarget.Module then + yield! sigDataAttributes + yield! codegenResults.ilNetModuleAttrs + ] + ) // Add attributes, version number, resources etc. - {mainModule with - StackReserveSize = tcConfig.stackReserveSize - Name = (if tcConfig.target = CompilerTarget.Module then FileSystemUtils.fileNameOfPath outfile else mainModule.Name) - SubSystemFlags = (if tcConfig.target = CompilerTarget.WinExe then 2 else 3) - Resources= resources - ImageBase = (match tcConfig.baseAddress with None -> 0x00400000l | Some b -> b) - IsDLL=(tcConfig.target = CompilerTarget.Dll || tcConfig.target=CompilerTarget.Module) - Platform = tcConfig.platform - Is32Bit=(match tcConfig.platform with Some X86 | Some ARM -> true | _ -> false) - Is64Bit=(match tcConfig.platform with Some AMD64 | Some IA64 | Some ARM64 -> true | _ -> false) - Is32BitPreferred = if tcConfig.prefer32Bit && not tcConfig.target.IsExe then (error(Error(FSComp.SR.invalidPlatformTarget(), rangeCmdArgs))) else tcConfig.prefer32Bit - CustomAttrsStored= - storeILCustomAttrs - (mkILCustomAttrs - [ if tcConfig.target = CompilerTarget.Module then - yield! sigDataAttributes - yield! codegenResults.ilNetModuleAttrs ]) - NativeResources=nativeResources - Manifest = manifest } + { mainModule with + StackReserveSize = tcConfig.stackReserveSize + Name = name + SubSystemFlags = (if tcConfig.target = CompilerTarget.WinExe then 2 else 3) + Resources = resources + ImageBase = imageBase + IsDLL = isDLL + Platform = tcConfig.platform + Is32Bit = is32bit + Is64Bit = is64bit + Is32BitPreferred = is32BitPreferred + CustomAttrsStored = attribs + NativeResources = nativeResources + Manifest = manifest + } diff --git a/src/Compiler/Driver/FxResolver.fs b/src/Compiler/Driver/FxResolver.fs index ff75963c159..2d1eb4ce7ae 100644 --- a/src/Compiler/Driver/FxResolver.fs +++ b/src/Compiler/Driver/FxResolver.fs @@ -19,9 +19,9 @@ open FSharp.Compiler.Text open FSharp.Compiler.IO type internal FxResolverLockToken() = - interface LockToken + interface LockToken -type internal FxResolverLock = Lock +type internal FxResolverLock = Lock /// Resolves the references for a chosen or currently-executing framework, for /// - script execution @@ -30,19 +30,28 @@ type internal FxResolverLock = Lock /// - out-of-project sources editing /// - default references for fsc.exe /// - default references for fsi.exe -type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdkRefs: bool, isInteractive: bool, rangeForErrors: range, sdkDirOverride: string option) = +type internal FxResolver + ( + assumeDotNetFramework: bool, + projectDir: string, + useSdkRefs: bool, + isInteractive: bool, + rangeForErrors: range, + sdkDirOverride: string option + ) = let fxlock = FxResolverLock() static let RequireFxResolverLock (_fxtok: FxResolverLockToken, _thingProtected: 'T) = () - /// We only try once for each directory (cleared on solution unload) to prevent conditions where + /// We only try once for each directory (cleared on solution unload) to prevent conditions where /// we repeatedly try to run dotnet.exe on every keystroke for a script - static let desiredDotNetSdkVersionForDirectoryCache = ConcurrentDictionary>() + static let desiredDotNetSdkVersionForDirectoryCache = + ConcurrentDictionary>() // Execute the process pathToExe passing the arguments: arguments with the working directory: workingDir timeout after timeout milliseconds -1 = wait forever // returns exit code, stdio and stderr as string arrays - let executeProcess pathToExe arguments (workingDir:string option) timeout = + let executeProcess pathToExe arguments (workingDir: string option) timeout = if not (String.IsNullOrEmpty pathToExe) then let errorsList = ResizeArray() let outputList = ResizeArray() @@ -52,44 +61,50 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk let outputDataReceived (message: string MaybeNull) = match message with | Null -> () - | NonNull message -> - lock outputlock (fun () -> outputList.Add(message)) + | NonNull message -> lock outputlock (fun () -> outputList.Add(message)) let errorDataReceived (message: string MaybeNull) = match message with | Null -> () - | NonNull message -> - lock errorslock (fun () -> errorsList.Add(message)) + | NonNull message -> lock errorslock (fun () -> errorsList.Add(message)) let psi = ProcessStartInfo() psi.FileName <- pathToExe - if workingDir.IsSome then + + if workingDir.IsSome then psi.WorkingDirectory <- workingDir.Value + psi.RedirectStandardOutput <- true psi.RedirectStandardError <- true psi.Arguments <- arguments psi.CreateNoWindow <- true - psi.EnvironmentVariables.Remove("MSBuildSDKsPath") // Host can sometimes add this, and it can break things + psi.EnvironmentVariables.Remove("MSBuildSDKsPath") // Host can sometimes add this, and it can break things psi.UseShellExecute <- false use p = new Process() p.StartInfo <- psi p.OutputDataReceived.Add(fun a -> outputDataReceived a.Data) - p.ErrorDataReceived.Add(fun a -> errorDataReceived a.Data) + p.ErrorDataReceived.Add(fun a -> errorDataReceived a.Data) if p.Start() then p.BeginOutputReadLine() p.BeginErrorReadLine() - if not(p.WaitForExit(timeout)) then + + if not (p.WaitForExit(timeout)) then // Timed out resolving throw a diagnostic. raise (TimeoutException(sprintf "Timeout executing command '%s' '%s'" psi.FileName psi.Arguments)) else p.WaitForExit() #if DEBUG if workingDir.IsSome then - FileSystem.OpenFileForWriteShim(Path.Combine(workingDir.Value, "StandardOutput.txt")).WriteAllLines(outputList) - FileSystem.OpenFileForWriteShim(Path.Combine(workingDir.Value, "StandardError.txt")).WriteAllLines(errorsList) + FileSystem + .OpenFileForWriteShim(Path.Combine(workingDir.Value, "StandardOutput.txt")) + .WriteAllLines(outputList) + + FileSystem + .OpenFileForWriteShim(Path.Combine(workingDir.Value, "StandardError.txt")) + .WriteAllLines(errorsList) #endif p.ExitCode, outputList.ToArray(), errorsList.ToArray() else @@ -97,146 +112,184 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk /// Find the relevant sdk version by running `dotnet --version` in the script/project location, /// taking into account any global.json - let tryGetDesiredDotNetSdkVersionForDirectoryInfo() = - desiredDotNetSdkVersionForDirectoryCache.GetOrAdd(projectDir, (fun _ -> - match getDotnetHostPath() with - | Some dotnetHostPath -> - try - let workingDir = - if FileSystem.DirectoryExistsShim(projectDir) then - Some projectDir + let tryGetDesiredDotNetSdkVersionForDirectoryInfo () = + desiredDotNetSdkVersionForDirectoryCache.GetOrAdd( + projectDir, + (fun _ -> + match getDotnetHostPath () with + | Some dotnetHostPath -> + try + let workingDir = + if FileSystem.DirectoryExistsShim(projectDir) then + Some projectDir + else + None + + let exitCode, output, errors = + executeProcess dotnetHostPath "--version" workingDir 30000 + + if exitCode <> 0 then + Result.Error( + Error( + FSComp.SR.scriptSdkNotDetermined (dotnetHostPath, projectDir, (errors |> String.concat "\n"), exitCode), + rangeForErrors + ) + ) else - None - let exitCode, output, errors = executeProcess dotnetHostPath "--version" workingDir 30000 - if exitCode <> 0 then - Result.Error (Error(FSComp.SR.scriptSdkNotDetermined(dotnetHostPath, projectDir, (errors |> String.concat "\n"), exitCode), rangeForErrors)) - else - Result.Ok (output |> String.concat "\n") - with err -> - Result.Error (Error(FSComp.SR.scriptSdkNotDetermined(dotnetHostPath, projectDir, err.Message, 1), rangeForErrors)) - | _ -> Result.Error (Error(FSComp.SR.scriptSdkNotDeterminedNoHost(), rangeForErrors)))) + Result.Ok(output |> String.concat "\n") + with err -> + Result.Error(Error(FSComp.SR.scriptSdkNotDetermined (dotnetHostPath, projectDir, err.Message, 1), rangeForErrors)) + | _ -> Result.Error(Error(FSComp.SR.scriptSdkNotDeterminedNoHost (), rangeForErrors))) + ) // We need to make sure the warning gets replayed each time, despite the lazy computations // To do this we pass it back as data and eventually replay it at the entry points to FxResolver. - let tryGetDesiredDotNetSdkVersionForDirectory() = - match tryGetDesiredDotNetSdkVersionForDirectoryInfo() with + let tryGetDesiredDotNetSdkVersionForDirectory () = + match tryGetDesiredDotNetSdkVersionForDirectoryInfo () with | Result.Ok res -> Some res, [] - | Result.Error exn -> None, [exn] + | Result.Error exn -> None, [ exn ] // This is used to replay the warnings generated in the function above. // It should not be used under the lazy on-demand computations in this type, nor should the warnings be explicitly ignored let replayWarnings (res, warnings: exn list) = - for exn in warnings do warning exn + for exn in warnings do + warning exn + res /// Compute the .NET Core SDK directory relevant to projectDir, used to infer the default target framework assemblies. /// /// On-demand because (a) some FxResolver are ephemeral (b) we want to avoid recomputation let trySdkDir = - lazy - // This path shouldn't be used with reflective processes - assert not isInteractive - match assumeDotNetFramework with - | true -> None, [] - | _ when not useSdkRefs -> None, [] - | _ -> - match sdkDirOverride with - | Some sdkDir -> Some sdkDir, [] - | None -> - let sdksDir = - match getDotnetHostDirectory() with - | Some dotnetDir -> - let candidate = FileSystem.GetFullPathShim(Path.Combine(dotnetDir, "sdk")) - if FileSystem.DirectoryExistsShim(candidate) then Some candidate else None - | None -> None - - match sdksDir with - | Some sdksDir -> - // Find the sdk version by running `dotnet --version` in the script/project location - let desiredSdkVer, warnings = tryGetDesiredDotNetSdkVersionForDirectory() - - let sdkDir = - DirectoryInfo(sdksDir).GetDirectories() - // Filter to the version reported by `dotnet --version` in the location, if that succeeded - // If it didn't succeed we will revert back to implementation assemblies, but still need an SDK - // to use, so we find the SDKs by looking for dotnet.runtimeconfig.json - |> Array.filter (fun di -> - match desiredSdkVer with - | None -> FileSystem.FileExistsShim(Path.Combine(di.FullName,"dotnet.runtimeconfig.json")) - | Some v -> di.Name = v) - |> Array.sortBy (fun di -> di.FullName) - |> Array.tryLast - |> Option.map (fun di -> di.FullName) - sdkDir, warnings + lazy + // This path shouldn't be used with reflective processes + assert not isInteractive + + match assumeDotNetFramework with + | true -> None, [] + | _ when not useSdkRefs -> None, [] | _ -> - None, [] + match sdkDirOverride with + | Some sdkDir -> Some sdkDir, [] + | None -> + let sdksDir = + match getDotnetHostDirectory () with + | Some dotnetDir -> + let candidate = FileSystem.GetFullPathShim(Path.Combine(dotnetDir, "sdk")) - let tryGetSdkDir() = trySdkDir.Force() + if FileSystem.DirectoryExistsShim(candidate) then + Some candidate + else + None + | None -> None + + match sdksDir with + | Some sdksDir -> + // Find the sdk version by running `dotnet --version` in the script/project location + let desiredSdkVer, warnings = tryGetDesiredDotNetSdkVersionForDirectory () + + let sdkDir = + DirectoryInfo(sdksDir).GetDirectories() + // Filter to the version reported by `dotnet --version` in the location, if that succeeded + // If it didn't succeed we will revert back to implementation assemblies, but still need an SDK + // to use, so we find the SDKs by looking for dotnet.runtimeconfig.json + |> Array.filter (fun di -> + match desiredSdkVer with + | None -> FileSystem.FileExistsShim(Path.Combine(di.FullName, "dotnet.runtimeconfig.json")) + | Some v -> di.Name = v) + |> Array.sortBy (fun di -> di.FullName) + |> Array.tryLast + |> Option.map (fun di -> di.FullName) + + sdkDir, warnings + | _ -> None, [] + + let tryGetSdkDir () = trySdkDir.Force() /// Get the framework implementation directory of the currently running process - let getRunningImplementationAssemblyDir() = + let getRunningImplementationAssemblyDir () = let fileName = Path.GetDirectoryName(typeof.Assembly.Location) - if String.IsNullOrWhiteSpace fileName then getFSharpCompilerLocation() else fileName + + if String.IsNullOrWhiteSpace fileName then + getFSharpCompilerLocation () + else + fileName // Compute the framework implementation directory, either of the selected SDK or the currently running process as a backup // F# interactive/reflective scenarios use the implementation directory of the currently running process // // On-demand because (a) some FxResolver are ephemeral (b) we want to avoid recomputation let implementationAssemblyDir = - lazy - if isInteractive then - getRunningImplementationAssemblyDir(), [] - else - let sdkDir, warnings = tryGetSdkDir() - match sdkDir with - | Some dir -> - try - let dotnetConfigFile = Path.Combine(dir, "dotnet.runtimeconfig.json") - use stream = FileSystem.OpenFileForReadShim(dotnetConfigFile) - let dotnetConfig = stream.ReadAllText() - let pattern = "\"version\": \"" - let startPos = dotnetConfig.IndexOf(pattern, StringComparison.OrdinalIgnoreCase) + pattern.Length - let endPos = dotnetConfig.IndexOf("\"", startPos) - let ver = dotnetConfig[startPos..endPos-1] - let path = FileSystem.GetFullPathShim(Path.Combine(dir, "..", "..", "shared", "Microsoft.NETCore.App", ver)) - if FileSystem.DirectoryExistsShim(path) then - path, warnings - else - getRunningImplementationAssemblyDir(), warnings - with e -> - let warn = Error(FSComp.SR.scriptSdkNotDeterminedUnexpected(e.Message), rangeForErrors) - let path = getRunningImplementationAssemblyDir() - path, [warn] - | _ -> - let path = getRunningImplementationAssemblyDir() - path, [] + lazy + if isInteractive then + getRunningImplementationAssemblyDir (), [] + else + let sdkDir, warnings = tryGetSdkDir () + + match sdkDir with + | Some dir -> + try + let dotnetConfigFile = Path.Combine(dir, "dotnet.runtimeconfig.json") + use stream = FileSystem.OpenFileForReadShim(dotnetConfigFile) + let dotnetConfig = stream.ReadAllText() + let pattern = "\"version\": \"" + + let startPos = + dotnetConfig.IndexOf(pattern, StringComparison.OrdinalIgnoreCase) + + pattern.Length + + let endPos = dotnetConfig.IndexOf("\"", startPos) + let ver = dotnetConfig[startPos .. endPos - 1] - let getImplementationAssemblyDir() = implementationAssemblyDir.Force() + let path = + FileSystem.GetFullPathShim(Path.Combine(dir, "..", "..", "shared", "Microsoft.NETCore.App", ver)) + + if FileSystem.DirectoryExistsShim(path) then + path, warnings + else + getRunningImplementationAssemblyDir (), warnings + with e -> + let warn = + Error(FSComp.SR.scriptSdkNotDeterminedUnexpected (e.Message), rangeForErrors) + + let path = getRunningImplementationAssemblyDir () + path, [ warn ] + | _ -> + let path = getRunningImplementationAssemblyDir () + path, [] + + let getImplementationAssemblyDir () = implementationAssemblyDir.Force() let getFSharpCoreLibraryName = "FSharp.Core" let getFsiLibraryName = "FSharp.Compiler.Interactive.Settings" // Use the FSharp.Core that is executing with the compiler as a backup reference - let getFSharpCoreImplementationReference() = Path.Combine(getFSharpCompilerLocation(), getFSharpCoreLibraryName + ".dll") + let getFSharpCoreImplementationReference () = + Path.Combine(getFSharpCompilerLocation (), getFSharpCoreLibraryName + ".dll") // Use the FSharp.Compiler.Interactive.Settings executing with the compiler as a backup reference - let getFsiLibraryImplementationReference() = Path.Combine(getFSharpCompilerLocation(), getFsiLibraryName + ".dll") + let getFsiLibraryImplementationReference () = + Path.Combine(getFSharpCompilerLocation (), getFsiLibraryName + ".dll") // Use the ValueTuple that is executing with the compiler if it is from System.ValueTuple // or the System.ValueTuple.dll that sits alongside the compiler. (Note we always ship one with the compiler) - let getSystemValueTupleImplementationReference() = - let implDir = getImplementationAssemblyDir() |> replayWarnings + let getSystemValueTupleImplementationReference () = + let implDir = getImplementationAssemblyDir () |> replayWarnings let probeFile = Path.Combine(implDir, "System.ValueTuple.dll") + if FileSystem.FileExistsShim(probeFile) then Some probeFile else try let asm = typeof>.Assembly + if asm.FullName.StartsWith("System.ValueTuple", StringComparison.OrdinalIgnoreCase) then Some asm.Location else - let valueTuplePath = Path.Combine(getFSharpCompilerLocation(), "System.ValueTuple.dll") + let valueTuplePath = + Path.Combine(getFSharpCompilerLocation (), "System.ValueTuple.dll") + if FileSystem.FileExistsShim(valueTuplePath) then Some valueTuplePath else @@ -251,13 +304,14 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk // it may be a subdirectory of a locally xcopied sdk or the global sdk // version is nuget format version id e.g 5.0.1-preview-4.3 // - let tryGetVersionedSubDirectory (path:string) (version:string) = + let tryGetVersionedSubDirectory (path: string) (version: string) = let zeroVersion = Version("0.0.0.0") // Split the version into a number + it's suffix let computeVersion (version: string) = let ver, suffix = let suffixPos = version.IndexOf('-') + if suffixPos >= 0 then version.Substring(0, suffixPos), version.Substring(suffixPos + 1) else @@ -267,8 +321,9 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk | true, v -> v, suffix | false, _ -> zeroVersion, suffix - let compareVersion (v1:Version * string) (v2:Version * string) = + let compareVersion (v1: Version * string) (v2: Version * string) = let fstCompare = (fst v1).CompareTo(fst v2) + if fstCompare <> 0 then fstCompare else @@ -280,8 +335,8 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk if directories.Length > 0 then directories |> Array.map (fun di -> computeVersion di.Name, di) - |> Array.filter(fun (v, _) -> (compareVersion v targetVersion) <= 0) - |> Array.sortWith (fun (v1,_) (v2,_) -> compareVersion v1 v2) + |> Array.filter (fun (v, _) -> (compareVersion v targetVersion) <= 0) + |> Array.sortWith (fun (v1, _) (v2, _) -> compareVersion v1 v2) |> Array.map snd |> Array.tryLast else @@ -302,187 +357,219 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk // // On-demand because (a) some FxResolver are ephemeral (b) we want to avoid recomputation let tryNetCoreRefsPackDirectoryRoot = - lazy - try - // Use the reference assemblies for the highest netcoreapp tfm that we find in that location that is - // lower than or equal to the implementation version. - let implDir, warnings = getImplementationAssemblyDir() - let version = DirectoryInfo(implDir).Name - if version.StartsWith("x") then - // Is running on the desktop - (None, None), warnings - else - let di = tryGetVersionedSubDirectory "packs/Microsoft.NETCore.App.Ref" version - match di with - | Some di -> (Some(di.Name), Some(di.Parent.FullName)), warnings - | None -> (None, None), warnings + lazy + try + // Use the reference assemblies for the highest netcoreapp tfm that we find in that location that is + // lower than or equal to the implementation version. + let implDir, warnings = getImplementationAssemblyDir () + let version = DirectoryInfo(implDir).Name + + if version.StartsWith("x") then + // Is running on the desktop + (None, None), warnings + else + let di = tryGetVersionedSubDirectory "packs/Microsoft.NETCore.App.Ref" version + + match di with + | Some di -> (Some(di.Name), Some(di.Parent.FullName)), warnings + | None -> (None, None), warnings with e -> - let warn = Error(FSComp.SR.scriptSdkNotDeterminedUnexpected(e.Message), rangeForErrors) - // This is defensive coding, we don't expect this exception to happen - // NOTE: consider reporting this exception as a warning - (None, None), [warn] + let warn = + Error(FSComp.SR.scriptSdkNotDeterminedUnexpected (e.Message), rangeForErrors) + // This is defensive coding, we don't expect this exception to happen + // NOTE: consider reporting this exception as a warning + (None, None), [ warn ] - let tryGetNetCoreRefsPackDirectoryRoot() = tryNetCoreRefsPackDirectoryRoot.Force() + let tryGetNetCoreRefsPackDirectoryRoot () = tryNetCoreRefsPackDirectoryRoot.Force() // Tries to figure out the tfm for the compiler instance. // On coreclr it uses the deps.json file // // On-demand because (a) some FxResolver are ephemeral (b) we want to avoid recomputation let tryRunningDotNetCoreTfm = - lazy - let file = - try - let asm = Assembly.GetEntryAssembly() - match asm with - | Null -> "" - | NonNull asm -> - let depsJsonPath = Path.ChangeExtension(asm.Location, "deps.json") - if FileSystem.FileExistsShim(depsJsonPath) then - use stream = FileSystem.OpenFileForReadShim(depsJsonPath) - stream.ReadAllText() - else - "" - with _ -> - // This is defensive coding, we don't expect this exception to happen - // NOTE: consider reporting this exception as a warning - "" - - let tfmPrefix=".NETCoreApp,Version=v" - let pattern = "\"name\": \"" + tfmPrefix - let startPos = - let startPos = file.IndexOf(pattern, StringComparison.OrdinalIgnoreCase) - if startPos >= 0 then startPos + pattern.Length else startPos - let length = - if startPos >= 0 then - let ep = file.IndexOf("\"", startPos) - if ep >= 0 then ep - startPos else ep - else -1 - match startPos, length with - | -1, _ - | _, -1 -> - if isRunningOnCoreClr then - // Running on coreclr but no deps.json was deployed with the host so default to 6.0 - Some "net6.0" - else - // Running on desktop - None - | pos, length -> - // use value from the deps.json file - let suffix = file.Substring(pos, length) - let prefix = - match Double.TryParse(suffix) with - | true, value when value < 5.0 -> "netcoreapp" - | _ -> "net" - Some (prefix + suffix) + lazy + let file = + try + let asm = Assembly.GetEntryAssembly() + + match asm with + | Null -> "" + | NonNull asm -> + let depsJsonPath = Path.ChangeExtension(asm.Location, "deps.json") + + if FileSystem.FileExistsShim(depsJsonPath) then + use stream = FileSystem.OpenFileForReadShim(depsJsonPath) + stream.ReadAllText() + else + "" + with _ -> + // This is defensive coding, we don't expect this exception to happen + // NOTE: consider reporting this exception as a warning + "" - let tryGetRunningDotNetCoreTfm() = tryRunningDotNetCoreTfm.Force() + let tfmPrefix = ".NETCoreApp,Version=v" + let pattern = "\"name\": \"" + tfmPrefix + + let startPos = + let startPos = file.IndexOf(pattern, StringComparison.OrdinalIgnoreCase) + + if startPos >= 0 then + startPos + pattern.Length + else + startPos + + let length = + if startPos >= 0 then + let ep = file.IndexOf("\"", startPos) + if ep >= 0 then ep - startPos else ep + else + -1 + + match startPos, length with + | -1, _ + | _, -1 -> + if isRunningOnCoreClr then + // Running on coreclr but no deps.json was deployed with the host so default to 6.0 + Some "net6.0" + else + // Running on desktop + None + | pos, length -> + // use value from the deps.json file + let suffix = file.Substring(pos, length) + + let prefix = + match Double.TryParse(suffix) with + | true, value when value < 5.0 -> "netcoreapp" + | _ -> "net" + + Some(prefix + suffix) + + let tryGetRunningDotNetCoreTfm () = tryRunningDotNetCoreTfm.Force() // Tries to figure out the tfm for the compiler instance on the Windows desktop // On full clr it uses the mscorlib version number let getRunningDotNetFrameworkTfm () = - let defaultMscorlibVersion = 4,8,3815,0 - let desktopProductVersionMonikers = [| - // major, minor, build, revision, moniker - 4, 8, 3815, 0, "net48" - 4, 8, 3761, 0, "net48" - 4, 7, 3190, 0, "net472" - 4, 7, 3062, 0, "net472" - 4, 7, 2600, 0, "net471" - 4, 7, 2558, 0, "net471" - 4, 7, 2053, 0, "net47" - 4, 7, 2046, 0, "net47" - 4, 6, 1590, 0, "net462" - 4, 6, 57, 0, "net462" - 4, 6, 1055, 0, "net461" - 4, 6, 81, 0, "net46" - 4, 0, 30319, 34209, "net452" - 4, 0, 30319, 17020, "net452" - 4, 0, 30319, 18408, "net451" - 4, 0, 30319, 17929, "net45" - 4, 0, 30319, 1, "net4" + let defaultMscorlibVersion = 4, 8, 3815, 0 + + let desktopProductVersionMonikers = + [| + // major, minor, build, revision, moniker + 4, 8, 3815, 0, "net48" + 4, 8, 3761, 0, "net48" + 4, 7, 3190, 0, "net472" + 4, 7, 3062, 0, "net472" + 4, 7, 2600, 0, "net471" + 4, 7, 2558, 0, "net471" + 4, 7, 2053, 0, "net47" + 4, 7, 2046, 0, "net47" + 4, 6, 1590, 0, "net462" + 4, 6, 57, 0, "net462" + 4, 6, 1055, 0, "net461" + 4, 6, 81, 0, "net46" + 4, 0, 30319, 34209, "net452" + 4, 0, 30319, 17020, "net452" + 4, 0, 30319, 18408, "net451" + 4, 0, 30319, 17929, "net45" + 4, 0, 30319, 1, "net4" |] - let majorPart, minorPart, buildPart, privatePart= + let majorPart, minorPart, buildPart, privatePart = try - let attrOpt = typeof.Assembly.GetCustomAttributes(typeof) |> Seq.tryHead + let attrOpt = + typeof.Assembly.GetCustomAttributes (typeof) + |> Seq.tryHead + match attrOpt with | Some attr -> - let fv = (downcast attr : AssemblyFileVersionAttribute).Version.Split([|'.'|]) |> Array.map(fun e -> Int32.Parse(e)) + let fv = + (downcast attr: AssemblyFileVersionAttribute).Version.Split([| '.' |]) + |> Array.map (fun e -> Int32.Parse(e)) + fv[0], fv[1], fv[2], fv[3] | _ -> defaultMscorlibVersion - with _ -> defaultMscorlibVersion + with _ -> + defaultMscorlibVersion - // Get the ProductVersion of this framework compare with table yield compatible monikers + // Get the ProductVersion of this framework compare with table compatible monikers match desktopProductVersionMonikers |> Array.tryFind (fun (major, minor, build, revision, _) -> - (majorPart >= major) && - (minorPart >= minor) && - (buildPart >= build) && - (privatePart >= revision)) with - | Some (_,_,_,_,moniker) -> - moniker + (majorPart >= major) + && (minorPart >= minor) + && (buildPart >= build) + && (privatePart >= revision)) + with + | Some (_, _, _, _, moniker) -> moniker | None -> // no TFM could be found, assume latest stable? "net48" let trySdkRefsPackDirectory = - lazy - let tfmPrefix = "netcoreapp" - let tfmCompare c1 c2 = - let deconstructTfmApp (netcoreApp: DirectoryInfo) = - let name = netcoreApp.Name - try - if name.StartsWith(tfmPrefix, StringComparison.InvariantCultureIgnoreCase) then - Some (Double.Parse(name.Substring(tfmPrefix.Length), NumberStyles.AllowDecimalPoint, CultureInfo.InvariantCulture)) - else + lazy + let tfmPrefix = "netcoreapp" + + let tfmCompare c1 c2 = + let deconstructTfmApp (netcoreApp: DirectoryInfo) = + let name = netcoreApp.Name + + try + if name.StartsWith(tfmPrefix, StringComparison.InvariantCultureIgnoreCase) then + Some( + Double.Parse(name.Substring(tfmPrefix.Length), NumberStyles.AllowDecimalPoint, CultureInfo.InvariantCulture) + ) + else + None + with _ -> + // This is defensive coding, we don't expect this exception to happen + // NOTE: consider reporting this exception as a warning None - with _ -> - // This is defensive coding, we don't expect this exception to happen - // NOTE: consider reporting this exception as a warning - None - if c1 = c2 then 0 - else - match (deconstructTfmApp c1), (deconstructTfmApp c2) with - | Some c1, Some c2 -> int(c1 - c2) - | None, Some _ -> -1 - | Some _, None -> 1 - | _ -> 0 - - match tryGetNetCoreRefsPackDirectoryRoot() with - | (Some version, Some root), warnings -> - try - let ref = Path.Combine(root, version, "ref") - let highestTfm = - DirectoryInfo(ref).GetDirectories() - |> Array.sortWith tfmCompare - |> Array.tryLast - - match highestTfm with - | Some tfm -> Some (Path.Combine(ref, tfm.Name)), warnings - | None -> None, warnings - with e -> - let warn = Error(FSComp.SR.scriptSdkNotDeterminedUnexpected(e.Message), rangeForErrors) - // This is defensive coding, we don't expect this exception to happen - // NOTE: consider reporting this exception as a warning - None, warnings @ [warn] - | _ -> None, [] + if c1 = c2 then + 0 + else + match (deconstructTfmApp c1), (deconstructTfmApp c2) with + | Some c1, Some c2 -> int (c1 - c2) + | None, Some _ -> -1 + | Some _, None -> 1 + | _ -> 0 + + match tryGetNetCoreRefsPackDirectoryRoot () with + | (Some version, Some root), warnings -> + try + let ref = Path.Combine(root, version, "ref") - let tryGetSdkRefsPackDirectory() = trySdkRefsPackDirectory.Force() + let highestTfm = + DirectoryInfo(ref).GetDirectories() + |> Array.sortWith tfmCompare + |> Array.tryLast + + match highestTfm with + | Some tfm -> Some(Path.Combine(ref, tfm.Name)), warnings + | None -> None, warnings + with e -> + let warn = + Error(FSComp.SR.scriptSdkNotDeterminedUnexpected (e.Message), rangeForErrors) + // This is defensive coding, we don't expect this exception to happen + // NOTE: consider reporting this exception as a warning + None, warnings @ [ warn ] + | _ -> None, [] + + let tryGetSdkRefsPackDirectory () = trySdkRefsPackDirectory.Force() let getDependenciesOf assemblyReferences = let assemblies = Dictionary() // Identify path to a dll in the framework directory from a simple name let frameworkPathFromSimpleName simpleName = - let implDir = getImplementationAssemblyDir() |> replayWarnings + let implDir = getImplementationAssemblyDir () |> replayWarnings let root = Path.Combine(implDir, simpleName) + let pathOpt = [| ""; ".dll"; ".exe" |] - |> Seq.tryPick(fun ext -> + |> Seq.tryPick (fun ext -> let path = root + ext - if FileSystem.FileExistsShim(path) then Some path - else None) + if FileSystem.FileExistsShim(path) then Some path else None) + match pathOpt with | Some path -> path | None -> root @@ -525,19 +612,24 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk | _ -> try let opts = - { metadataOnly = MetadataOnlyFlag.Yes // turn this off here as we need the actual IL code - reduceMemoryUsage = ReduceMemoryFlag.Yes - pdbDirPath = None - tryGetMetadataSnapshot = (fun _ -> None) (* tryGetMetadataSnapshot *) } + { + metadataOnly = MetadataOnlyFlag.Yes // turn this off here as we need the actual IL code + reduceMemoryUsage = ReduceMemoryFlag.Yes + pdbDirPath = None + tryGetMetadataSnapshot = (fun _ -> None) (* tryGetMetadataSnapshot *) + } let reader = OpenILModuleReader path opts assemblies.Add(referenceName, path) + for reference in reader.ILAssemblyRefs do traverseDependencies reference.Name // There are many native assemblies which can't be cracked, raising exceptions - with _ -> () - with _ -> () + with _ -> + () + with _ -> + () assemblyReferences |> List.iter traverseDependencies assemblies @@ -548,332 +640,352 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk // (a) included in the environment used for all .fsx files (see service.fs) // (b) included in environment for files 'orphaned' from a project context // -- for orphaned files (files in VS without a project context) - let getDotNetFrameworkDefaultReferences useFsiAuxLib = [ - yield "mscorlib" - yield "System" - yield "System.Xml" - yield "System.Runtime.Remoting" - yield "System.Runtime.Serialization.Formatters.Soap" - yield "System.Data" - yield "System.Drawing" - yield "System.Core" - yield "System.Configuration" - - yield getFSharpCoreLibraryName - if useFsiAuxLib then yield fsiLibraryName - - // always include a default reference to System.ValueTuple.dll in scripts and out-of-project sources - match getSystemValueTupleImplementationReference () with - | None -> () - | Some v -> yield v - - // These are the Portable-profile and .NET Standard 1.6 dependencies of FSharp.Core.dll. These are needed - // when an F# script references an F# profile 7, 78, 259 or .NET Standard 1.6 component which in turn refers - // to FSharp.Core for profile 7, 78, 259 or .NET Standard. - yield "netstandard" - yield "System.Runtime" // lots of types - yield "System.Linq" // System.Linq.Expressions.Expression - yield "System.Reflection" // System.Reflection.ParameterInfo - yield "System.Linq.Expressions" // System.Linq.IQueryable - yield "System.Threading.Tasks" // valuetype [System.Threading.Tasks]System.Threading.CancellationToken - yield "System.IO" // System.IO.TextWriter - yield "System.Net.Requests" // System.Net.WebResponse etc. - yield "System.Collections" // System.Collections.Generic.List - yield "System.Runtime.Numerics" // BigInteger - yield "System.Threading" // OperationCanceledException - yield "System.Web" - yield "System.Web.Services" - yield "System.Windows.Forms" - yield "System.Numerics" - ] + let getDotNetFrameworkDefaultReferences useFsiAuxLib = + [ + "mscorlib" + "System" + "System.Xml" + "System.Runtime.Remoting" + "System.Runtime.Serialization.Formatters.Soap" + "System.Data" + "System.Drawing" + "System.Core" + "System.Configuration" + + getFSharpCoreLibraryName + if useFsiAuxLib then fsiLibraryName + + // always include a default reference to System.ValueTuple.dll in scripts and out-of-project sources + match getSystemValueTupleImplementationReference () with + | None -> () + | Some v -> v + + // These are the Portable-profile and .NET Standard 1.6 dependencies of FSharp.Core.dll. These are needed + // when an F# script references an F# profile 7, 78, 259 or .NET Standard 1.6 component which in turn refers + // to FSharp.Core for profile 7, 78, 259 or .NET Standard. + "netstandard" + "System.Runtime" // lots of types + "System.Linq" // System.Linq.Expressions.Expression + "System.Reflection" // System.Reflection.ParameterInfo + "System.Linq.Expressions" // System.Linq.IQueryable + "System.Threading.Tasks" // valuetype [System.Threading.Tasks]System.Threading.CancellationToken + "System.IO" // System.IO.TextWriter + "System.Net.Requests" // System.Net.WebResponse etc. + "System.Collections" // System.Collections.Generic.List + "System.Runtime.Numerics" // BigInteger + "System.Threading" // OperationCanceledException + "System.Web" + "System.Web.Services" + "System.Windows.Forms" + "System.Numerics" + ] let getDotNetCoreImplementationReferences useFsiAuxLib = - let implDir = getImplementationAssemblyDir() |> replayWarnings + let implDir = getImplementationAssemblyDir () |> replayWarnings + let roots = - [ yield! Directory.GetFiles(implDir, "*.dll") - yield getFSharpCoreImplementationReference() - if useFsiAuxLib then yield getFsiLibraryImplementationReference() ] + [ + yield! Directory.GetFiles(implDir, "*.dll") + getFSharpCoreImplementationReference () + if useFsiAuxLib then getFsiLibraryImplementationReference () + ] + (getDependenciesOf roots).Values |> Seq.toList // A set of assemblies to always consider to be system assemblies. A common set of these can be used a shared // resources between projects in the compiler services. Also all assemblies where well-known system types exist // referenced from TcGlobals must be listed here. let systemAssemblies = - HashSet [ - // NOTE: duplicates are ok in this list - - // .NET Framework list - yield "mscorlib" - yield "netstandard" - yield "System" - yield getFSharpCoreLibraryName - yield "FSharp.Compiler.Interactive.Settings" - yield "Microsoft.CSharp" - yield "Microsoft.VisualBasic" - yield "Microsoft.VisualBasic.Core" - yield "Microsoft.Win32.Primitives" - yield "Microsoft.Win32.Registry" - yield "System.AppContext" - yield "System.Buffers" - yield "System.Collections" - yield "System.Collections.Concurrent" - yield "System.Collections.Immutable" - yield "System.Collections.NonGeneric" - yield "System.Collections.Specialized" - yield "System.ComponentModel" - yield "System.ComponentModel.Annotations" - yield "System.ComponentModel.DataAnnotations" - yield "System.ComponentModel.EventBasedAsync" - yield "System.ComponentModel.Primitives" - yield "System.ComponentModel.TypeConverter" - yield "System.Configuration" - yield "System.Console" - yield "System.Core" - yield "System.Data" - yield "System.Data.Common" - yield "System.Data.DataSetExtensions" - yield "System.Deployment" - yield "System.Design" - yield "System.Diagnostics.Contracts" - yield "System.Diagnostics.Debug" - yield "System.Diagnostics.DiagnosticSource" - yield "System.Diagnostics.FileVersionInfo" - yield "System.Diagnostics.Process" - yield "System.Diagnostics.StackTrace" - yield "System.Diagnostics.TextWriterTraceListener" - yield "System.Diagnostics.Tools" - yield "System.Diagnostics.TraceSource" - yield "System.Diagnostics.Tracing" - yield "System.Drawing" - yield "System.Drawing.Primitives" - yield "System.Dynamic.Runtime" - yield "System.Formats.Asn1" - yield "System.Globalization" - yield "System.Globalization.Calendars" - yield "System.Globalization.Extensions" - yield "System.IO" - yield "System.IO.Compression" - yield "System.IO.Compression.Brotli" - yield "System.IO.Compression.FileSystem" - yield "System.IO.Compression.ZipFile" - yield "System.IO.FileSystem" - yield "System.IO.FileSystem.DriveInfo" - yield "System.IO.FileSystem.Primitives" - yield "System.IO.FileSystem.Watcher" - yield "System.IO.IsolatedStorage" - yield "System.IO.MemoryMappedFiles" - yield "System.IO.Pipes" - yield "System.IO.UnmanagedMemoryStream" - yield "System.Linq" - yield "System.Linq.Expressions" - yield "System.Linq.Expressions" - yield "System.Linq.Parallel" - yield "System.Linq.Queryable" - yield "System.Memory" - yield "System.Messaging" - yield "System.Net" - yield "System.Net.Http" - yield "System.Net.Http.Json" - yield "System.Net.HttpListener" - yield "System.Net.Mail" - yield "System.Net.NameResolution" - yield "System.Net.NetworkInformation" - yield "System.Net.Ping" - yield "System.Net.Primitives" - yield "System.Net.Requests" - yield "System.Net.Security" - yield "System.Net.ServicePoint" - yield "System.Net.Sockets" - yield "System.Net.WebClient" - yield "System.Net.WebHeaderCollection" - yield "System.Net.WebProxy" - yield "System.Net.WebSockets" - yield "System.Net.WebSockets.Client" - yield "System.Numerics" - yield "System.Numerics.Vectors" - yield "System.ObjectModel" - yield "System.Observable" - yield "System.Private.Uri" - yield "System.Reflection" - yield "System.Reflection.DispatchProxy" - yield "System.Reflection.Emit" - yield "System.Reflection.Emit.ILGeneration" - yield "System.Reflection.Emit.Lightweight" - yield "System.Reflection.Extensions" - yield "System.Reflection.Metadata" - yield "System.Reflection.Primitives" - yield "System.Reflection.TypeExtensions" - yield "System.Resources.Reader" - yield "System.Resources.ResourceManager" - yield "System.Resources.Writer" - yield "System.Runtime" - yield "System.Runtime.CompilerServices.Unsafe" - yield "System.Runtime.CompilerServices.VisualC" - yield "System.Runtime.Extensions" - yield "System.Runtime.Handles" - yield "System.Runtime.InteropServices" - yield "System.Runtime.InteropServices.PInvoke" - yield "System.Runtime.InteropServices.RuntimeInformation" - yield "System.Runtime.InteropServices.WindowsRuntime" - yield "System.Runtime.Intrinsics" - yield "System.Runtime.Loader" - yield "System.Runtime.Numerics" - yield "System.Runtime.Remoting" - yield "System.Runtime.Serialization" - yield "System.Runtime.Serialization.Formatters" - yield "System.Runtime.Serialization.Formatters.Soap" - yield "System.Runtime.Serialization.Json" - yield "System.Runtime.Serialization.Primitives" - yield "System.Runtime.Serialization.Xml" - yield "System.Security" - yield "System.Security.Claims" - yield "System.Security.Cryptography.Algorithms" - yield "System.Security.Cryptography.Cng" - yield "System.Security.Cryptography.Csp" - yield "System.Security.Cryptography.Encoding" - yield "System.Security.Cryptography.OpenSsl" - yield "System.Security.Cryptography.Primitives" - yield "System.Security.Cryptography.X509Certificates" - yield "System.Security.Principal" - yield "System.Security.Principal.Windows" - yield "System.Security.SecureString" - yield "System.ServiceModel.Web" - yield "System.ServiceProcess" - yield "System.Text.Encoding" - yield "System.Text.Encoding.CodePages" - yield "System.Text.Encoding.Extensions" - yield "System.Text.Encodings.Web" - yield "System.Text.Json" - yield "System.Text.RegularExpressions" - yield "System.Threading" - yield "System.Threading.Channels" - yield "System.Threading.Overlapped" - yield "System.Threading.Tasks" - yield "System.Threading.Tasks.Dataflow" - yield "System.Threading.Tasks.Extensions" - yield "System.Threading.Tasks.Parallel" - yield "System.Threading.Thread" - yield "System.Threading.ThreadPool" - yield "System.Threading.Timer" - yield "System.Transactions" - yield "System.Transactions.Local" - yield "System.ValueTuple" - yield "System.Web" - yield "System.Web.HttpUtility" - yield "System.Web.Services" - yield "System.Windows" - yield "System.Windows.Forms" - yield "System.Xml" - yield "System.Xml.Linq" - yield "System.Xml.ReaderWriter" - yield "System.Xml.Serialization" - yield "System.Xml.XDocument" - yield "System.Xml.XmlDocument" - yield "System.Xml.XmlSerializer" - yield "System.Xml.XPath" - yield "System.Xml.XPath.XDocument" - yield "WindowsBase" - ] + HashSet + [ + // NOTE: duplicates are ok in this list + + // .NET Framework list + "mscorlib" + "netstandard" + "System" + getFSharpCoreLibraryName + "FSharp.Compiler.Interactive.Settings" + "Microsoft.CSharp" + "Microsoft.VisualBasic" + "Microsoft.VisualBasic.Core" + "Microsoft.Win32.Primitives" + "Microsoft.Win32.Registry" + "System.AppContext" + "System.Buffers" + "System.Collections" + "System.Collections.Concurrent" + "System.Collections.Immutable" + "System.Collections.NonGeneric" + "System.Collections.Specialized" + "System.ComponentModel" + "System.ComponentModel.Annotations" + "System.ComponentModel.DataAnnotations" + "System.ComponentModel.EventBasedAsync" + "System.ComponentModel.Primitives" + "System.ComponentModel.TypeConverter" + "System.Configuration" + "System.Console" + "System.Core" + "System.Data" + "System.Data.Common" + "System.Data.DataSetExtensions" + "System.Deployment" + "System.Design" + "System.Diagnostics.Contracts" + "System.Diagnostics.Debug" + "System.Diagnostics.DiagnosticSource" + "System.Diagnostics.FileVersionInfo" + "System.Diagnostics.Process" + "System.Diagnostics.StackTrace" + "System.Diagnostics.TextWriterTraceListener" + "System.Diagnostics.Tools" + "System.Diagnostics.TraceSource" + "System.Diagnostics.Tracing" + "System.Drawing" + "System.Drawing.Primitives" + "System.Dynamic.Runtime" + "System.Formats.Asn1" + "System.Globalization" + "System.Globalization.Calendars" + "System.Globalization.Extensions" + "System.IO" + "System.IO.Compression" + "System.IO.Compression.Brotli" + "System.IO.Compression.FileSystem" + "System.IO.Compression.ZipFile" + "System.IO.FileSystem" + "System.IO.FileSystem.DriveInfo" + "System.IO.FileSystem.Primitives" + "System.IO.FileSystem.Watcher" + "System.IO.IsolatedStorage" + "System.IO.MemoryMappedFiles" + "System.IO.Pipes" + "System.IO.UnmanagedMemoryStream" + "System.Linq" + "System.Linq.Expressions" + "System.Linq.Expressions" + "System.Linq.Parallel" + "System.Linq.Queryable" + "System.Memory" + "System.Messaging" + "System.Net" + "System.Net.Http" + "System.Net.Http.Json" + "System.Net.HttpListener" + "System.Net.Mail" + "System.Net.NameResolution" + "System.Net.NetworkInformation" + "System.Net.Ping" + "System.Net.Primitives" + "System.Net.Requests" + "System.Net.Security" + "System.Net.ServicePoint" + "System.Net.Sockets" + "System.Net.WebClient" + "System.Net.WebHeaderCollection" + "System.Net.WebProxy" + "System.Net.WebSockets" + "System.Net.WebSockets.Client" + "System.Numerics" + "System.Numerics.Vectors" + "System.ObjectModel" + "System.Observable" + "System.Private.Uri" + "System.Reflection" + "System.Reflection.DispatchProxy" + "System.Reflection.Emit" + "System.Reflection.Emit.ILGeneration" + "System.Reflection.Emit.Lightweight" + "System.Reflection.Extensions" + "System.Reflection.Metadata" + "System.Reflection.Primitives" + "System.Reflection.TypeExtensions" + "System.Resources.Reader" + "System.Resources.ResourceManager" + "System.Resources.Writer" + "System.Runtime" + "System.Runtime.CompilerServices.Unsafe" + "System.Runtime.CompilerServices.VisualC" + "System.Runtime.Extensions" + "System.Runtime.Handles" + "System.Runtime.InteropServices" + "System.Runtime.InteropServices.PInvoke" + "System.Runtime.InteropServices.RuntimeInformation" + "System.Runtime.InteropServices.WindowsRuntime" + "System.Runtime.Intrinsics" + "System.Runtime.Loader" + "System.Runtime.Numerics" + "System.Runtime.Remoting" + "System.Runtime.Serialization" + "System.Runtime.Serialization.Formatters" + "System.Runtime.Serialization.Formatters.Soap" + "System.Runtime.Serialization.Json" + "System.Runtime.Serialization.Primitives" + "System.Runtime.Serialization.Xml" + "System.Security" + "System.Security.Claims" + "System.Security.Cryptography.Algorithms" + "System.Security.Cryptography.Cng" + "System.Security.Cryptography.Csp" + "System.Security.Cryptography.Encoding" + "System.Security.Cryptography.OpenSsl" + "System.Security.Cryptography.Primitives" + "System.Security.Cryptography.X509Certificates" + "System.Security.Principal" + "System.Security.Principal.Windows" + "System.Security.SecureString" + "System.ServiceModel.Web" + "System.ServiceProcess" + "System.Text.Encoding" + "System.Text.Encoding.CodePages" + "System.Text.Encoding.Extensions" + "System.Text.Encodings.Web" + "System.Text.Json" + "System.Text.RegularExpressions" + "System.Threading" + "System.Threading.Channels" + "System.Threading.Overlapped" + "System.Threading.Tasks" + "System.Threading.Tasks.Dataflow" + "System.Threading.Tasks.Extensions" + "System.Threading.Tasks.Parallel" + "System.Threading.Thread" + "System.Threading.ThreadPool" + "System.Threading.Timer" + "System.Transactions" + "System.Transactions.Local" + "System.ValueTuple" + "System.Web" + "System.Web.HttpUtility" + "System.Web.Services" + "System.Windows" + "System.Windows.Forms" + "System.Xml" + "System.Xml.Linq" + "System.Xml.ReaderWriter" + "System.Xml.Serialization" + "System.Xml.XDocument" + "System.Xml.XmlDocument" + "System.Xml.XmlSerializer" + "System.Xml.XPath" + "System.Xml.XPath.XDocument" + "WindowsBase" + ] member _.GetSystemAssemblies() = systemAssemblies member _.IsInReferenceAssemblyPackDirectory fileName = - fxlock.AcquireLock <| fun fxtok -> - RequireFxResolverLock(fxtok, "assuming all member require lock") + fxlock.AcquireLock(fun fxtok -> + RequireFxResolverLock(fxtok, "assuming all member require lock") - match tryGetNetCoreRefsPackDirectoryRoot() |> replayWarnings with - | _, Some root -> - let path = Path.GetDirectoryName(fileName) - path.StartsWith(root, StringComparison.OrdinalIgnoreCase) - | _ -> false + match tryGetNetCoreRefsPackDirectoryRoot () |> replayWarnings with + | _, Some root -> + let path = Path.GetDirectoryName(fileName) + path.StartsWith(root, StringComparison.OrdinalIgnoreCase) + | _ -> false) member _.TryGetSdkDir() = - fxlock.AcquireLock <| fun fxtok -> - RequireFxResolverLock(fxtok, "assuming all member require lock") - tryGetSdkDir() |> replayWarnings + fxlock.AcquireLock(fun fxtok -> + RequireFxResolverLock(fxtok, "assuming all member require lock") + tryGetSdkDir () |> replayWarnings) /// Gets the selected target framework moniker, e.g netcore3.0, net472, and the running rid of the current machine member _.GetTfmAndRid() = - fxlock.AcquireLock <| fun fxtok -> - RequireFxResolverLock(fxtok, "assuming all member require lock") - // Interactive processes read their own configuration to find the running tfm + fxlock.AcquireLock(fun fxtok -> + RequireFxResolverLock(fxtok, "assuming all member require lock") + // Interactive processes read their own configuration to find the running tfm + + let tfm = + if isInteractive then + match tryGetRunningDotNetCoreTfm () with + | Some tfm -> tfm + | _ -> getRunningDotNetFrameworkTfm () + else + let sdkDir = tryGetSdkDir () |> replayWarnings - let tfm = - if isInteractive then - match tryGetRunningDotNetCoreTfm() with - | Some tfm -> tfm - | _ -> getRunningDotNetFrameworkTfm () - else - let sdkDir = tryGetSdkDir() |> replayWarnings - match sdkDir with - | Some dir -> - let dotnetConfigFile = Path.Combine(dir, "dotnet.runtimeconfig.json") - use stream = FileSystem.OpenFileForReadShim(dotnetConfigFile) - let dotnetConfig = stream.ReadAllText() - let pattern = "\"tfm\": \"" - let startPos = dotnetConfig.IndexOf(pattern, StringComparison.OrdinalIgnoreCase) + pattern.Length - let endPos = dotnetConfig.IndexOf("\"", startPos) - let tfm = dotnetConfig[startPos..endPos-1] - //printfn "GetTfmAndRid, tfm = '%s'" tfm - tfm - | None -> - match tryGetRunningDotNetCoreTfm() with - | Some tfm -> tfm - | _ -> getRunningDotNetFrameworkTfm () - - // Computer valid dotnet-rids for this environment: - // https://docs.microsoft.com/en-us/dotnet/core/rid-catalog - // - // Where rid is: win, win-x64, win-x86, osx-x64, linux-x64 etc ... - let runningRid = - let processArchitecture = RuntimeInformation.ProcessArchitecture - let baseRid = - if RuntimeInformation.IsOSPlatform(OSPlatform.Windows) then "win" - elif RuntimeInformation.IsOSPlatform(OSPlatform.OSX) then "osx" - else "linux" - match processArchitecture with - | Architecture.X64 -> baseRid + "-x64" - | Architecture.X86 -> baseRid + "-x86" - | Architecture.Arm64 -> baseRid + "-arm64" - | _ -> baseRid + "-arm" - - tfm, runningRid + match sdkDir with + | Some dir -> + let dotnetConfigFile = Path.Combine(dir, "dotnet.runtimeconfig.json") + use stream = FileSystem.OpenFileForReadShim(dotnetConfigFile) + let dotnetConfig = stream.ReadAllText() + let pattern = "\"tfm\": \"" + + let startPos = + dotnetConfig.IndexOf(pattern, StringComparison.OrdinalIgnoreCase) + + pattern.Length + + let endPos = dotnetConfig.IndexOf("\"", startPos) + let tfm = dotnetConfig[startPos .. endPos - 1] + //printfn "GetTfmAndRid, tfm = '%s'" tfm + tfm + | None -> + match tryGetRunningDotNetCoreTfm () with + | Some tfm -> tfm + | _ -> getRunningDotNetFrameworkTfm () + + // Computer valid dotnet-rids for this environment: + // https://docs.microsoft.com/en-us/dotnet/core/rid-catalog + // + // Where rid is: win, win-x64, win-x86, osx-x64, linux-x64 etc ... + let runningRid = + let processArchitecture = RuntimeInformation.ProcessArchitecture + + let baseRid = + if RuntimeInformation.IsOSPlatform(OSPlatform.Windows) then + "win" + elif RuntimeInformation.IsOSPlatform(OSPlatform.OSX) then + "osx" + else + "linux" + + match processArchitecture with + | Architecture.X64 -> baseRid + "-x64" + | Architecture.X86 -> baseRid + "-x86" + | Architecture.Arm64 -> baseRid + "-arm64" + | _ -> baseRid + "-arm" + + tfm, runningRid) static member ClearStaticCaches() = desiredDotNetSdkVersionForDirectoryCache.Clear() member _.GetFrameworkRefsPackDirectory() = - fxlock.AcquireLock <| fun fxtok -> - RequireFxResolverLock(fxtok, "assuming all member require lock") - tryGetSdkRefsPackDirectory() |> replayWarnings + fxlock.AcquireLock(fun fxtok -> + RequireFxResolverLock(fxtok, "assuming all member require lock") + tryGetSdkRefsPackDirectory () |> replayWarnings) member _.TryGetDesiredDotNetSdkVersionForDirectory() = - fxlock.AcquireLock <| fun fxtok -> - RequireFxResolverLock(fxtok, "assuming all member require lock") - tryGetDesiredDotNetSdkVersionForDirectoryInfo() + fxlock.AcquireLock(fun fxtok -> + RequireFxResolverLock(fxtok, "assuming all member require lock") + tryGetDesiredDotNetSdkVersionForDirectoryInfo ()) // The set of references entered into the TcConfigBuilder for scripts prior to computing the load closure. member _.GetDefaultReferences useFsiAuxLib = - fxlock.AcquireLock <| fun fxtok -> - RequireFxResolverLock(fxtok, "assuming all member require lock") - let defaultReferences = - if assumeDotNetFramework then - getDotNetFrameworkDefaultReferences useFsiAuxLib, assumeDotNetFramework - else - if useSdkRefs then + fxlock.AcquireLock(fun fxtok -> + RequireFxResolverLock(fxtok, "assuming all member require lock") + + let defaultReferences = + if assumeDotNetFramework then + getDotNetFrameworkDefaultReferences useFsiAuxLib, assumeDotNetFramework + else if useSdkRefs then // Go fetch references - let sdkDir = tryGetSdkRefsPackDirectory() |> replayWarnings + let sdkDir = tryGetSdkRefsPackDirectory () |> replayWarnings + match sdkDir with | Some path -> try let sdkReferences = - [ yield! Directory.GetFiles(path, "*.dll") - yield getFSharpCoreImplementationReference() - if useFsiAuxLib then yield getFsiLibraryImplementationReference() - ] |> List.filter(fun f -> systemAssemblies.Contains(Path.GetFileNameWithoutExtension(f))) + [ + yield! Directory.GetFiles(path, "*.dll") + getFSharpCoreImplementationReference () + if useFsiAuxLib then getFsiLibraryImplementationReference () + ] + |> List.filter (fun f -> systemAssemblies.Contains(Path.GetFileNameWithoutExtension(f))) + sdkReferences, false with e -> - warning (Error(FSComp.SR.scriptSdkNotDeterminedUnexpected(e.Message), rangeForErrors)) + warning (Error(FSComp.SR.scriptSdkNotDeterminedUnexpected (e.Message), rangeForErrors)) // This is defensive coding, we don't expect this exception to happen if isRunningOnCoreClr then // If running on .NET Core and something goes wrong with getting the @@ -894,4 +1006,5 @@ type internal FxResolver(assumeDotNetFramework: bool, projectDir: string, useSdk getDotNetFrameworkDefaultReferences useFsiAuxLib, true else getDotNetCoreImplementationReferences useFsiAuxLib, assumeDotNetFramework - defaultReferences + + defaultReferences) diff --git a/src/Compiler/Driver/OptimizeInputs.fs b/src/Compiler/Driver/OptimizeInputs.fs index 54f800b2a46..f2ce410199b 100644 --- a/src/Compiler/Driver/OptimizeInputs.fs +++ b/src/Compiler/Driver/OptimizeInputs.fs @@ -20,11 +20,16 @@ open FSharp.Compiler.TypedTreeOps let mutable showTermFileCount = 0 -let PrintWholeAssemblyImplementation g (tcConfig:TcConfig) outfile header expr = +let PrintWholeAssemblyImplementation g (tcConfig: TcConfig) outfile header expr = if tcConfig.showTerms then if tcConfig.writeTermsToFiles then let fileName = outfile + ".terms" - use f = FileSystem.OpenFileForWriteShim(fileName + "-" + string showTermFileCount + "-" + header, FileMode.Create).GetWriter() + + use f = + FileSystem + .OpenFileForWriteShim(fileName + "-" + string showTermFileCount + "-" + header, FileMode.Create) + .GetWriter() + showTermFileCount <- showTermFileCount + 1 LayoutRender.outL f (Display.squashTo 192 (DebugPrint.implFilesL g expr)) else @@ -37,13 +42,24 @@ let AddExternalCcuToOptimizationEnv tcGlobals optEnv (ccuinfo: ImportedAssembly) | None -> optEnv | Some data -> Optimizer.BindCcu ccuinfo.FSharpViewOfMetadata data optEnv tcGlobals -let GetInitialOptimizationEnv (tcImports:TcImports, tcGlobals:TcGlobals) = +let GetInitialOptimizationEnv (tcImports: TcImports, tcGlobals: TcGlobals) = let ccuinfos = tcImports.GetImportedAssemblies() let optEnv = Optimizer.IncrementalOptimizationEnv.Empty let optEnv = List.fold (AddExternalCcuToOptimizationEnv tcGlobals) optEnv ccuinfos optEnv -let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles) = +let ApplyAllOptimizations + ( + tcConfig: TcConfig, + tcGlobals, + tcVal, + outfile, + importMap, + isIncrementalFragment, + optEnv, + ccu: CcuThunk, + implFiles + ) = // NOTE: optEnv - threads through // // Always optimize once - the results of this step give the x-module optimization @@ -52,7 +68,9 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM PrintWholeAssemblyImplementation tcGlobals tcConfig outfile "pass-start" implFiles #if DEBUG if tcConfig.showOptimizationData then - dprintf "Expression prior to optimization:\n%s\n" (LayoutRender.showL (Display.squashTo 192 (DebugPrint.implFilesL tcGlobals implFiles))) + dprintf + "Expression prior to optimization:\n%s\n" + (LayoutRender.showL (Display.squashTo 192 (DebugPrint.implFilesL tcGlobals implFiles))) if tcConfig.showOptimizationData then dprintf "CCU prior to optimization:\n%s\n" (LayoutRender.showL (Display.squashTo 192 (DebugPrint.entityL tcGlobals ccu.Contents))) @@ -63,8 +81,16 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM // Only do abstract_big_targets on the first pass! Only do it when TLR is on! let optSettings = tcConfig.optSettings - let optSettings = { optSettings with abstractBigTargets = tcConfig.doTLR } - let optSettings = { optSettings with reportingPhase = true } + + let optSettings = + { optSettings with + abstractBigTargets = tcConfig.doTLR + } + + let optSettings = + { optSettings with + reportingPhase = true + } let results, (optEnvFirstLoop, _, _, _) = ((optEnv0, optEnv0, optEnv0, SignatureHidingInfo.Empty), implFiles) @@ -73,18 +99,33 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM //ReportTime tcConfig ("Initial simplify") let (optEnvFirstLoop, implFile, implFileOptData, hidden), optimizeDuringCodeGen = - Optimizer.OptimizeImplFile - (optSettings, ccu, tcGlobals, tcVal, importMap, - optEnvFirstLoop, isIncrementalFragment, tcConfig.fsiMultiAssemblyEmit, - tcConfig.emitTailcalls, hidden, implFile) + Optimizer.OptimizeImplFile( + optSettings, + ccu, + tcGlobals, + tcVal, + importMap, + optEnvFirstLoop, + isIncrementalFragment, + tcConfig.fsiMultiAssemblyEmit, + tcConfig.emitTailcalls, + hidden, + implFile + ) let implFile = LowerLocalMutables.TransformImplFile tcGlobals importMap implFile // Only do this on the first pass! - let optSettings = { optSettings with abstractBigTargets = false; reportingPhase = false } + let optSettings = + { optSettings with + abstractBigTargets = false + reportingPhase = false + } #if DEBUG if tcConfig.showOptimizationData then - dprintf "Optimization implFileOptData:\n%s\n" (LayoutRender.showL (Display.squashTo 192 (Optimizer.moduleInfoL tcGlobals implFileOptData))) + dprintf + "Optimization implFileOptData:\n%s\n" + (LayoutRender.showL (Display.squashTo 192 (Optimizer.moduleInfoL tcGlobals implFileOptData))) #endif let implFile, optEnvExtraLoop = @@ -92,10 +133,19 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM //ReportTime tcConfig ("Extra simplification loop") let (optEnvExtraLoop, implFile, _, _), _ = - Optimizer.OptimizeImplFile - (optSettings, ccu, tcGlobals, tcVal, importMap, - optEnvExtraLoop, isIncrementalFragment, tcConfig.fsiMultiAssemblyEmit, - tcConfig.emitTailcalls, hidden, implFile) + Optimizer.OptimizeImplFile( + optSettings, + ccu, + tcGlobals, + tcVal, + importMap, + optEnvExtraLoop, + isIncrementalFragment, + tcConfig.fsiMultiAssemblyEmit, + tcConfig.emitTailcalls, + hidden, + implFile + ) //PrintWholeAssemblyImplementation tcConfig outfile (sprintf "extra-loop-%d" n) implFile implFile, optEnvExtraLoop @@ -108,24 +158,36 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile = implFile |> Detuple.DetupleImplFile ccu tcGlobals //PrintWholeAssemblyImplementation tcConfig outfile "post-detuple" implFile implFile - else implFile + else + implFile let implFile = if tcConfig.doTLR then - implFile |> InnerLambdasToTopLevelFuncs.MakeTopLevelRepresentationDecisions ccu tcGlobals - else implFile + implFile + |> InnerLambdasToTopLevelFuncs.MakeTopLevelRepresentationDecisions ccu tcGlobals + else + implFile - let implFile = - LowerCalls.LowerImplFile tcGlobals implFile + let implFile = LowerCalls.LowerImplFile tcGlobals implFile let implFile, optEnvFinalSimplify = if tcConfig.doFinalSimplify then //ReportTime tcConfig ("Final simplify pass") let (optEnvFinalSimplify, implFile, _, _), _ = - Optimizer.OptimizeImplFile - (optSettings, ccu, tcGlobals, tcVal, importMap, optEnvFinalSimplify, - isIncrementalFragment, tcConfig.fsiMultiAssemblyEmit, tcConfig.emitTailcalls, hidden, implFile) + Optimizer.OptimizeImplFile( + optSettings, + ccu, + tcGlobals, + tcVal, + importMap, + optEnvFinalSimplify, + isIncrementalFragment, + tcConfig.fsiMultiAssemblyEmit, + tcConfig.emitTailcalls, + hidden, + implFile + ) //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile implFile, optEnvFinalSimplify @@ -133,8 +195,10 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM implFile, optEnvFinalSimplify let implFile = - { ImplFile = implFile - OptimizeDuringCodeGen = optimizeDuringCodeGen } + { + ImplFile = implFile + OptimizeDuringCodeGen = optimizeDuringCodeGen + } (implFile, implFileOptData), (optEnvFirstLoop, optEnvExtraLoop, optEnvFinalSimplify, hidden)) @@ -149,17 +213,20 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM // ILX generation //---------------------------------------------------------------------------- -let CreateIlxAssemblyGenerator (_tcConfig:TcConfig, tcImports:TcImports, tcGlobals, tcVal, generatedCcu) = - let ilxGenerator = IlxAssemblyGenerator(tcImports.GetImportMap(), tcGlobals, tcVal, generatedCcu) +let CreateIlxAssemblyGenerator (_tcConfig: TcConfig, tcImports: TcImports, tcGlobals, tcVal, generatedCcu) = + let ilxGenerator = + IlxAssemblyGenerator(tcImports.GetImportMap(), tcGlobals, tcVal, generatedCcu) + let ccus = tcImports.GetCcusInDeclOrder() ilxGenerator.AddExternalCcus ccus ilxGenerator -let GenerateIlxCode ( +let GenerateIlxCode + ( ilxBackend, isInteractiveItExpr, isInteractiveOnMono, - tcConfig:TcConfig, + tcConfig: TcConfig, topAttrs: TopAttribs, optimizedImpls, fragName, @@ -167,35 +234,39 @@ let GenerateIlxCode ( ) = let mainMethodInfo = - if (tcConfig.target = CompilerTarget.Dll) || (tcConfig.target = CompilerTarget.Module) then - None - else Some topAttrs.mainMethodAttrs + if (tcConfig.target = CompilerTarget.Dll) + || (tcConfig.target = CompilerTarget.Module) then + None + else + Some topAttrs.mainMethodAttrs let ilxGenOpts: IlxGenOptions = - { generateFilterBlocks = tcConfig.generateFilterBlocks - emitConstantArraysUsingStaticDataBlobs = not isInteractiveOnMono - workAroundReflectionEmitBugs = tcConfig.isInteractive - generateDebugSymbols = tcConfig.debuginfo - fragName = fragName - localOptimizationsEnabled= tcConfig.optSettings.LocalOptimizationsEnabled - testFlagEmitFeeFeeAs100001 = tcConfig.testFlagEmitFeeFeeAs100001 - mainMethodInfo= mainMethodInfo - ilxBackend = ilxBackend - fsiMultiAssemblyEmit = tcConfig.fsiMultiAssemblyEmit - isInteractive = tcConfig.isInteractive - isInteractiveItExpr = isInteractiveItExpr - alwaysCallVirt = tcConfig.alwaysCallVirt } - - ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs, topAttrs.netModuleAttrs) + { + generateFilterBlocks = tcConfig.generateFilterBlocks + emitConstantArraysUsingStaticDataBlobs = not isInteractiveOnMono + workAroundReflectionEmitBugs = tcConfig.isInteractive + generateDebugSymbols = tcConfig.debuginfo + fragName = fragName + localOptimizationsEnabled = tcConfig.optSettings.LocalOptimizationsEnabled + testFlagEmitFeeFeeAs100001 = tcConfig.testFlagEmitFeeFeeAs100001 + mainMethodInfo = mainMethodInfo + ilxBackend = ilxBackend + fsiMultiAssemblyEmit = tcConfig.fsiMultiAssemblyEmit + isInteractive = tcConfig.isInteractive + isInteractiveItExpr = isInteractiveItExpr + alwaysCallVirt = tcConfig.alwaysCallVirt + } + + ilxGenerator.GenerateCode(ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs, topAttrs.netModuleAttrs) //---------------------------------------------------------------------------- // Assembly ref normalization: make sure all assemblies are referred to // by the same references. Only used for static linking. //---------------------------------------------------------------------------- -let NormalizeAssemblyRefs (ctok, ilGlobals: ILGlobals, tcImports:TcImports) scoref = +let NormalizeAssemblyRefs (ctok, ilGlobals: ILGlobals, tcImports: TcImports) scoref = let normalizeAssemblyRefByName nm = - match tcImports.TryFindDllInfo (ctok, Range.rangeStartup, nm, lookupOnly=false) with + match tcImports.TryFindDllInfo(ctok, Range.rangeStartup, nm, lookupOnly = false) with | Some dllInfo -> dllInfo.ILScopeRef | None -> scoref @@ -205,7 +276,12 @@ let NormalizeAssemblyRefs (ctok, ilGlobals: ILGlobals, tcImports:TcImports) scor | ILScopeRef.PrimaryAssembly -> normalizeAssemblyRefByName ilGlobals.primaryAssemblyName | ILScopeRef.Assembly aref -> normalizeAssemblyRefByName aref.Name -let GetGeneratedILModuleName (t:CompilerTarget) (s:string) = +let GetGeneratedILModuleName (t: CompilerTarget) (s: string) = // return the name of the file as a module name - let ext = match t with CompilerTarget.Dll -> "dll" | CompilerTarget.Module -> "netmodule" | _ -> "exe" + let ext = + match t with + | CompilerTarget.Dll -> "dll" + | CompilerTarget.Module -> "netmodule" + | _ -> "exe" + s + "." + ext diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index b98425605d1..889abccff5f 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -42,11 +42,20 @@ open FSharp.Compiler.TcGlobals let CanonicalizeFilename fileName = let basic = FileSystemUtils.fileNameOfPath fileName - String.capitalize (try FileSystemUtils.chopExtension basic with _ -> basic) + + String.capitalize ( + try + FileSystemUtils.chopExtension basic + with _ -> + basic + ) let IsScript fileName = FSharpScriptFileSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) +let IsMLCompatFile fileName = + FSharpMLCompatFileSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) + // Give a unique name to the different kinds of inputs. Used to correlate signature and implementation files // QualFileNameOfModuleName - files with a single module declaration or an anonymous module let QualFileNameOfModuleName m fileName modname = @@ -61,186 +70,291 @@ let ComputeQualifiedNameOfFileFromUniquePath (m, p: string list) = let QualFileNameOfSpecs fileName specs = match specs with - | [SynModuleOrNamespaceSig(longId = modname; kind = kind; range = m)] when kind.IsModule -> QualFileNameOfModuleName m fileName modname - | [SynModuleOrNamespaceSig(kind = kind; range = m)] when not kind.IsModule -> QualFileNameOfFilename m fileName + | [ SynModuleOrNamespaceSig (longId = modname; kind = kind; range = m) ] when kind.IsModule -> + QualFileNameOfModuleName m fileName modname + | [ SynModuleOrNamespaceSig (kind = kind; range = m) ] when not kind.IsModule -> QualFileNameOfFilename m fileName | _ -> QualFileNameOfFilename (mkRange fileName pos0 pos0) fileName let QualFileNameOfImpls fileName specs = match specs with - | [SynModuleOrNamespace(longId = modname; kind = kind; range = m)] when kind.IsModule -> QualFileNameOfModuleName m fileName modname - | [SynModuleOrNamespace(kind = kind; range = m)] when not kind.IsModule -> QualFileNameOfFilename m fileName + | [ SynModuleOrNamespace (longId = modname; kind = kind; range = m) ] when kind.IsModule -> QualFileNameOfModuleName m fileName modname + | [ SynModuleOrNamespace (kind = kind; range = m) ] when not kind.IsModule -> QualFileNameOfFilename m fileName | _ -> QualFileNameOfFilename (mkRange fileName pos0 pos0) fileName let PrependPathToQualFileName x (QualifiedNameOfFile q) = - ComputeQualifiedNameOfFileFromUniquePath (q.idRange, pathOfLid x@[q.idText]) + ComputeQualifiedNameOfFileFromUniquePath(q.idRange, pathOfLid x @ [ q.idText ]) -let PrependPathToImpl x (SynModuleOrNamespace(longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia)) = - SynModuleOrNamespace(x@longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia) +let PrependPathToImpl x (SynModuleOrNamespace (longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia)) = + SynModuleOrNamespace(x @ longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia) -let PrependPathToSpec x (SynModuleOrNamespaceSig(longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia)) = - SynModuleOrNamespaceSig(x@longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia) +let PrependPathToSpec x (SynModuleOrNamespaceSig (longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia)) = + SynModuleOrNamespaceSig(x @ longId, isRecursive, kind, decls, xmlDoc, attribs, accessibility, range, trivia) let PrependPathToInput x inp = match inp with | ParsedInput.ImplFile (ParsedImplFileInput (b, c, q, d, hd, impls, e, trivia)) -> - ParsedInput.ImplFile (ParsedImplFileInput (b, c, PrependPathToQualFileName x q, d, hd, List.map (PrependPathToImpl x) impls, e, trivia)) + ParsedInput.ImplFile( + ParsedImplFileInput(b, c, PrependPathToQualFileName x q, d, hd, List.map (PrependPathToImpl x) impls, e, trivia) + ) | ParsedInput.SigFile (ParsedSigFileInput (b, q, d, hd, specs, trivia)) -> - ParsedInput.SigFile (ParsedSigFileInput (b, PrependPathToQualFileName x q, d, hd, List.map (PrependPathToSpec x) specs, trivia)) + ParsedInput.SigFile(ParsedSigFileInput(b, PrependPathToQualFileName x q, d, hd, List.map (PrependPathToSpec x) specs, trivia)) + +let IsValidAnonModuleName (modname: string) = + modname |> String.forall (fun c -> Char.IsLetterOrDigit c || c = '_') let ComputeAnonModuleName check defaultNamespace fileName (m: range) = let modname = CanonicalizeFilename fileName - if check && not (modname |> String.forall (fun c -> Char.IsLetterOrDigit c || c = '_')) then - if not (fileName.EndsWith("fsx", StringComparison.OrdinalIgnoreCase) || fileName.EndsWith("fsscript", StringComparison.OrdinalIgnoreCase)) then - warning(Error(FSComp.SR.buildImplicitModuleIsNotLegalIdentifier(modname, (FileSystemUtils.fileNameOfPath fileName)), m)) + + if check && not (IsValidAnonModuleName modname) && not (IsScript fileName) then + warning (Error(FSComp.SR.buildImplicitModuleIsNotLegalIdentifier (modname, (FileSystemUtils.fileNameOfPath fileName)), m)) + let combined = - match defaultNamespace with - | None -> modname - | Some ns -> textOfPath [ns;modname] + match defaultNamespace with + | None -> modname + | Some ns -> textOfPath [ ns; modname ] let anonymousModuleNameRange = let fileName = m.FileName mkRange fileName pos0 pos0 + pathToSynLid anonymousModuleNameRange (splitNamespace combined) +let FileRequiresModuleOrNamespaceDecl isLast isExe fileName = + not (isLast && isExe) && not (IsScript fileName || IsMLCompatFile fileName) + let PostParseModuleImpl (_i, defaultNamespace, isLastCompiland, fileName, impl) = match impl with - | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid, isRec, kind, decls, xmlDoc, attribs, access, m, trivia)) -> + | ParsedImplFileFragment.NamedModule (SynModuleOrNamespace (lid, isRec, kind, decls, xmlDoc, attribs, access, m, trivia)) -> let lid = match lid with - | [id] when kind.IsModule && id.idText = MangledGlobalName -> - error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(), id.idRange)) + | [ id ] when kind.IsModule && id.idText = MangledGlobalName -> + error (Error(FSComp.SR.buildInvalidModuleOrNamespaceName (), id.idRange)) | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid + SynModuleOrNamespace(lid, isRec, kind, decls, xmlDoc, attribs, access, m, trivia) - | ParsedImplFileFragment.AnonModule (defs, m)-> + | ParsedImplFileFragment.AnonModule (defs, m) -> let isLast, isExe = isLastCompiland - if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName)) then + + if FileRequiresModuleOrNamespaceDecl isLast isExe fileName then match defs with - | SynModuleDecl.NestedModule _ :: _ -> errorR(Error(FSComp.SR.noEqualSignAfterModule(), trimRangeToLine m)) - | _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(), trimRangeToLine m)) + | SynModuleDecl.NestedModule _ :: _ -> errorR (Error(FSComp.SR.noEqualSignAfterModule (), trimRangeToLine m)) + | _ -> errorR (Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule (), trimRangeToLine m)) + + let modname = + ComputeAnonModuleName (not (isNil defs)) defaultNamespace fileName (trimRangeToLine m) + + let trivia: SynModuleOrNamespaceTrivia = + { + ModuleKeyword = None + NamespaceKeyword = None + } - let modname = ComputeAnonModuleName (not (isNil defs)) defaultNamespace fileName (trimRangeToLine m) - let trivia: SynModuleOrNamespaceTrivia = { ModuleKeyword = None; NamespaceKeyword = None } SynModuleOrNamespace(modname, false, SynModuleOrNamespaceKind.AnonModule, defs, PreXmlDoc.Empty, [], None, m, trivia) - | ParsedImplFileFragment.NamespaceFragment (lid, isRecursive, kind, decls, xmlDoc, attributes, range, trivia)-> + | ParsedImplFileFragment.NamespaceFragment (lid, isRecursive, kind, decls, xmlDoc, attributes, range, trivia) -> let lid, kind = match lid with | id :: rest when id.idText = MangledGlobalName -> - rest, if List.isEmpty rest then SynModuleOrNamespaceKind.GlobalNamespace else kind + let kind = + if rest.IsEmpty then + SynModuleOrNamespaceKind.GlobalNamespace + else + kind + + rest, kind | _ -> lid, kind + SynModuleOrNamespace(lid, isRecursive, kind, decls, xmlDoc, attributes, None, range, trivia) let PostParseModuleSpec (_i, defaultNamespace, isLastCompiland, fileName, intf) = match intf with - | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid, isRec, kind, decls, xmlDoc, attribs, access, m, trivia)) -> + | ParsedSigFileFragment.NamedModule (SynModuleOrNamespaceSig (lid, isRec, kind, decls, xmlDoc, attribs, access, m, trivia)) -> let lid = match lid with - | [id] when kind.IsModule && id.idText = MangledGlobalName -> - error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(), id.idRange)) + | [ id ] when kind.IsModule && id.idText = MangledGlobalName -> + error (Error(FSComp.SR.buildInvalidModuleOrNamespaceName (), id.idRange)) | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid + SynModuleOrNamespaceSig(lid, isRec, SynModuleOrNamespaceKind.NamedModule, decls, xmlDoc, attribs, access, m, trivia) | ParsedSigFileFragment.AnonModule (defs, m) -> let isLast, isExe = isLastCompiland - if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName)) then + + if FileRequiresModuleOrNamespaceDecl isLast isExe fileName then match defs with - | SynModuleSigDecl.NestedModule _ :: _ -> errorR(Error(FSComp.SR.noEqualSignAfterModule(), m)) - | _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(), m)) + | SynModuleSigDecl.NestedModule _ :: _ -> errorR (Error(FSComp.SR.noEqualSignAfterModule (), m)) + | _ -> errorR (Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule (), m)) + + let modname = + ComputeAnonModuleName (not (isNil defs)) defaultNamespace fileName (trimRangeToLine m) + + let trivia: SynModuleOrNamespaceSigTrivia = + { + ModuleKeyword = None + NamespaceKeyword = None + } - let modname = ComputeAnonModuleName (not (isNil defs)) defaultNamespace fileName (trimRangeToLine m) - let trivia: SynModuleOrNamespaceSigTrivia = { ModuleKeyword = None; NamespaceKeyword = None } SynModuleOrNamespaceSig(modname, false, SynModuleOrNamespaceKind.AnonModule, defs, PreXmlDoc.Empty, [], None, m, trivia) - | ParsedSigFileFragment.NamespaceFragment (lid, isRecursive, kind, decls, xmlDoc, attributes, range, trivia)-> + | ParsedSigFileFragment.NamespaceFragment (lid, isRecursive, kind, decls, xmlDoc, attributes, range, trivia) -> let lid, kind = match lid with | id :: rest when id.idText = MangledGlobalName -> - rest, if List.isEmpty rest then SynModuleOrNamespaceKind.GlobalNamespace else kind + let kind = + if rest.IsEmpty then + SynModuleOrNamespaceKind.GlobalNamespace + else + kind + + rest, kind | _ -> lid, kind + SynModuleOrNamespaceSig(lid, isRecursive, kind, decls, xmlDoc, attributes, None, range, trivia) let GetScopedPragmasForInput input = match input with - | ParsedInput.SigFile (ParsedSigFileInput (scopedPragmas=pragmas)) -> pragmas - | ParsedInput.ImplFile (ParsedImplFileInput (scopedPragmas=pragmas)) -> pragmas + | ParsedInput.SigFile (ParsedSigFileInput (scopedPragmas = pragmas)) -> pragmas + | ParsedInput.ImplFile (ParsedImplFileInput (scopedPragmas = pragmas)) -> pragmas let GetScopedPragmasForHashDirective hd = - [ match hd with - | ParsedHashDirective("nowarn", numbers, m) -> - for s in numbers do - match s with - | ParsedHashDirectiveArgument.SourceIdentifier _ -> () - | ParsedHashDirectiveArgument.String (s, _, _) -> - match GetWarningNumber(m, s) with - | None -> () - | Some n -> yield ScopedPragma.WarningOff(m, n) - | _ -> () ] + [ + match hd with + | ParsedHashDirective ("nowarn", numbers, m) -> + for s in numbers do + match s with + | ParsedHashDirectiveArgument.SourceIdentifier _ -> () + | ParsedHashDirectiveArgument.String (s, _, _) -> + match GetWarningNumber(m, s) with + | None -> () + | Some n -> ScopedPragma.WarningOff(m, n) + | _ -> () + ] let private collectCodeComments (lexbuf: UnicodeLexing.Lexbuf) (tripleSlashComments: range list) = - [ yield! LexbufCommentStore.GetComments(lexbuf); yield! (List.map CommentTrivia.LineComment tripleSlashComments) ] + [ + yield! LexbufCommentStore.GetComments(lexbuf) + yield! (List.map CommentTrivia.LineComment tripleSlashComments) + ] |> List.sortBy (function | CommentTrivia.LineComment r | CommentTrivia.BlockComment r -> r.StartLine, r.StartColumn) -let PostParseModuleImpls (defaultNamespace, fileName, isLastCompiland, ParsedImplFile (hashDirectives, impls), lexbuf: UnicodeLexing.Lexbuf, tripleSlashComments: range list) = - match impls |> List.rev |> List.tryPick (function ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(longId = lid)) -> Some lid | _ -> None) with - | Some lid when impls.Length > 1 -> - errorR(Error(FSComp.SR.buildMultipleToplevelModules(), rangeOfLid lid)) - | _ -> - () - let impls = impls |> List.mapi (fun i x -> PostParseModuleImpl (i, defaultNamespace, isLastCompiland, fileName, x)) +let PostParseModuleImpls + ( + defaultNamespace, + fileName, + isLastCompiland, + ParsedImplFile (hashDirectives, impls), + lexbuf: UnicodeLexing.Lexbuf, + tripleSlashComments: range list + ) = + let othersWithSameName = + impls + |> List.rev + |> List.tryPick (function + | ParsedImplFileFragment.NamedModule (SynModuleOrNamespace (longId = lid)) -> Some lid + | _ -> None) + + match othersWithSameName with + | Some lid when impls.Length > 1 -> errorR (Error(FSComp.SR.buildMultipleToplevelModules (), rangeOfLid lid)) + | _ -> () + + let impls = + impls + |> List.mapi (fun i x -> PostParseModuleImpl(i, defaultNamespace, isLastCompiland, fileName, x)) + let qualName = QualFileNameOfImpls fileName impls let isScript = IsScript fileName let scopedPragmas = - [ for SynModuleOrNamespace(decls = decls) in impls do - for d in decls do - match d with - | SynModuleDecl.HashDirective (hd, _) -> yield! GetScopedPragmasForHashDirective hd - | _ -> () - for hd in hashDirectives do - yield! GetScopedPragmasForHashDirective hd ] + [ + for SynModuleOrNamespace (decls = decls) in impls do + for d in decls do + match d with + | SynModuleDecl.HashDirective (hd, _) -> yield! GetScopedPragmasForHashDirective hd + | _ -> () + for hd in hashDirectives do + yield! GetScopedPragmasForHashDirective hd + ] let conditionalDirectives = LexbufIfdefStore.GetTrivia(lexbuf) let codeComments = collectCodeComments lexbuf tripleSlashComments - let trivia: ParsedImplFileInputTrivia = { ConditionalDirectives = conditionalDirectives; CodeComments = codeComments } - - ParsedInput.ImplFile (ParsedImplFileInput (fileName, isScript, qualName, scopedPragmas, hashDirectives, impls, isLastCompiland, trivia)) - -let PostParseModuleSpecs (defaultNamespace, fileName, isLastCompiland, ParsedSigFile (hashDirectives, specs), lexbuf: UnicodeLexing.Lexbuf, tripleSlashComments: range list) = - match specs |> List.rev |> List.tryPick (function ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(longId = lid)) -> Some lid | _ -> None) with - | Some lid when specs.Length > 1 -> - errorR(Error(FSComp.SR.buildMultipleToplevelModules(), rangeOfLid lid)) - | _ -> - () - let specs = specs |> List.mapi (fun i x -> PostParseModuleSpec(i, defaultNamespace, isLastCompiland, fileName, x)) + let trivia: ParsedImplFileInputTrivia = + { + ConditionalDirectives = conditionalDirectives + CodeComments = codeComments + } + + ParsedInput.ImplFile(ParsedImplFileInput(fileName, isScript, qualName, scopedPragmas, hashDirectives, impls, isLastCompiland, trivia)) + +let PostParseModuleSpecs + ( + defaultNamespace, + fileName, + isLastCompiland, + ParsedSigFile (hashDirectives, specs), + lexbuf: UnicodeLexing.Lexbuf, + tripleSlashComments: range list + ) = + let othersWithSameName = + specs + |> List.rev + |> List.tryPick (function + | ParsedSigFileFragment.NamedModule (SynModuleOrNamespaceSig (longId = lid)) -> Some lid + | _ -> None) + + match othersWithSameName with + | Some lid when specs.Length > 1 -> errorR (Error(FSComp.SR.buildMultipleToplevelModules (), rangeOfLid lid)) + | _ -> () + + let specs = + specs + |> List.mapi (fun i x -> PostParseModuleSpec(i, defaultNamespace, isLastCompiland, fileName, x)) + let qualName = QualFileNameOfSpecs fileName specs + let scopedPragmas = - [ for SynModuleOrNamespaceSig(decls = decls) in specs do - for d in decls do - match d with - | SynModuleSigDecl.HashDirective(hd, _) -> yield! GetScopedPragmasForHashDirective hd - | _ -> () - for hd in hashDirectives do - yield! GetScopedPragmasForHashDirective hd ] + [ + for SynModuleOrNamespaceSig (decls = decls) in specs do + for d in decls do + match d with + | SynModuleSigDecl.HashDirective (hd, _) -> yield! GetScopedPragmasForHashDirective hd + | _ -> () + for hd in hashDirectives do + yield! GetScopedPragmasForHashDirective hd + ] let conditionalDirectives = LexbufIfdefStore.GetTrivia(lexbuf) let codeComments = collectCodeComments lexbuf tripleSlashComments - let trivia: ParsedSigFileInputTrivia = { ConditionalDirectives = conditionalDirectives; CodeComments = codeComments } - ParsedInput.SigFile (ParsedSigFileInput (fileName, qualName, scopedPragmas, hashDirectives, specs, trivia)) + let trivia: ParsedSigFileInputTrivia = + { + ConditionalDirectives = conditionalDirectives + CodeComments = codeComments + } + + ParsedInput.SigFile(ParsedSigFileInput(fileName, qualName, scopedPragmas, hashDirectives, specs, trivia)) -type ModuleNamesDict = Map> +type ModuleNamesDict = Map> /// Checks if a module name is already given and deduplicates the name if needed. let DeduplicateModuleName (moduleNamesDict: ModuleNamesDict) fileName (qualNameOfFile: QualifiedNameOfFile) = let path = Path.GetDirectoryName fileName - let path = if FileSystem.IsPathRootedShim path then try FileSystem.GetFullPathShim path with _ -> path else path + + let path = + if FileSystem.IsPathRootedShim path then + try + FileSystem.GetFullPathShim path + with _ -> + path + else + path + match moduleNamesDict.TryGetValue qualNameOfFile.Text with | true, paths -> if paths.ContainsKey path then @@ -248,26 +362,61 @@ let DeduplicateModuleName (moduleNamesDict: ModuleNamesDict) fileName (qualNameO else let count = paths.Count + 1 let id = qualNameOfFile.Id - let qualNameOfFileT = if count = 1 then qualNameOfFile else QualifiedNameOfFile(Ident(id.idText + "___" + count.ToString(), id.idRange)) - let moduleNamesDictT = moduleNamesDict.Add(qualNameOfFile.Text, paths.Add(path, qualNameOfFileT)) + + let qualNameOfFileT = + if count = 1 then + qualNameOfFile + else + QualifiedNameOfFile(Ident(id.idText + "___" + count.ToString(), id.idRange)) + + let moduleNamesDictT = + moduleNamesDict.Add(qualNameOfFile.Text, paths.Add(path, qualNameOfFileT)) + qualNameOfFileT, moduleNamesDictT | _ -> - let moduleNamesDictT = moduleNamesDict.Add(qualNameOfFile.Text, Map.empty.Add(path, qualNameOfFile)) + let moduleNamesDictT = + moduleNamesDict.Add(qualNameOfFile.Text, Map.empty.Add(path, qualNameOfFile)) + qualNameOfFile, moduleNamesDictT /// Checks if a ParsedInput is using a module name that was already given and deduplicates the name if needed. let DeduplicateParsedInputModuleName (moduleNamesDict: ModuleNamesDict) input = match input with - | ParsedInput.ImplFile (ParsedImplFileInput.ParsedImplFileInput (fileName, isScript, qualNameOfFile, scopedPragmas, hashDirectives, modules, (isLastCompiland, isExe), trivia)) -> - let qualNameOfFileT, moduleNamesDictT = DeduplicateModuleName moduleNamesDict fileName qualNameOfFile - let inputT = ParsedInput.ImplFile (ParsedImplFileInput.ParsedImplFileInput (fileName, isScript, qualNameOfFileT, scopedPragmas, hashDirectives, modules, (isLastCompiland, isExe), trivia)) - inputT, moduleNamesDictT - | ParsedInput.SigFile (ParsedSigFileInput.ParsedSigFileInput (fileName, qualNameOfFile, scopedPragmas, hashDirectives, modules, trivia)) -> - let qualNameOfFileT, moduleNamesDictT = DeduplicateModuleName moduleNamesDict fileName qualNameOfFile - let inputT = ParsedInput.SigFile (ParsedSigFileInput.ParsedSigFileInput (fileName, qualNameOfFileT, scopedPragmas, hashDirectives, modules, trivia)) - inputT, moduleNamesDictT - -let ParseInput (lexer, diagnosticOptions:FSharpDiagnosticOptions, diagnosticsLogger: DiagnosticsLogger, lexbuf: UnicodeLexing.Lexbuf, defaultNamespace, fileName, isLastCompiland) = + | ParsedInput.ImplFile implFile -> + let (ParsedImplFileInput (fileName, isScript, qualNameOfFile, scopedPragmas, hashDirectives, modules, flags, trivia)) = + implFile + + let qualNameOfFileR, moduleNamesDictR = + DeduplicateModuleName moduleNamesDict fileName qualNameOfFile + + let implFileR = + ParsedImplFileInput(fileName, isScript, qualNameOfFileR, scopedPragmas, hashDirectives, modules, flags, trivia) + + let inputR = ParsedInput.ImplFile implFileR + inputR, moduleNamesDictR + | ParsedInput.SigFile sigFile -> + let (ParsedSigFileInput (fileName, qualNameOfFile, scopedPragmas, hashDirectives, modules, trivia)) = + sigFile + + let qualNameOfFileR, moduleNamesDictR = + DeduplicateModuleName moduleNamesDict fileName qualNameOfFile + + let sigFileR = + ParsedSigFileInput(fileName, qualNameOfFileR, scopedPragmas, hashDirectives, modules, trivia) + + let inputT = ParsedInput.SigFile sigFileR + inputT, moduleNamesDictR + +let ParseInput + ( + lexer, + diagnosticOptions: FSharpDiagnosticOptions, + diagnosticsLogger: DiagnosticsLogger, + lexbuf: UnicodeLexing.Lexbuf, + defaultNamespace, + fileName, + isLastCompiland + ) = // The assert below is almost ok, but it fires in two cases: // - fsi.exe sometimes passes "stdin" as a dummy file name // - if you have a #line directive, e.g. @@ -277,39 +426,46 @@ let ParseInput (lexer, diagnosticOptions:FSharpDiagnosticOptions, diagnosticsLog // Delay sending errors and warnings until after the file is parsed. This gives us a chance to scrape the // #nowarn declarations for the file let delayLogger = CapturingDiagnosticsLogger("Parsing") - use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> delayLogger) + use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> delayLogger) use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse let mutable scopedPragmas = [] + try let input = - if mlCompatSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) then + if FSharpMLCompatFileSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) then if lexbuf.SupportsFeature LanguageFeature.MLCompatRevisions then - errorR(Error(FSComp.SR.buildInvalidSourceFileExtensionML fileName, rangeStartup)) + errorR (Error(FSComp.SR.buildInvalidSourceFileExtensionML fileName, rangeStartup)) else - mlCompatWarning (FSComp.SR.buildCompilingExtensionIsForML()) rangeStartup + mlCompatWarning (FSComp.SR.buildCompilingExtensionIsForML ()) rangeStartup // Call the appropriate parser - for signature files or implementation files if FSharpImplFileSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) then let impl = Parser.implementationFile lexer lexbuf - let tripleSlashComments = LexbufLocalXmlDocStore.ReportInvalidXmlDocPositions(lexbuf) - PostParseModuleImpls (defaultNamespace, fileName, isLastCompiland, impl, lexbuf, tripleSlashComments) + + let tripleSlashComments = + LexbufLocalXmlDocStore.ReportInvalidXmlDocPositions(lexbuf) + + PostParseModuleImpls(defaultNamespace, fileName, isLastCompiland, impl, lexbuf, tripleSlashComments) elif FSharpSigFileSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) then let intfs = Parser.signatureFile lexer lexbuf - let tripleSlashComments = LexbufLocalXmlDocStore.ReportInvalidXmlDocPositions(lexbuf) - PostParseModuleSpecs (defaultNamespace, fileName, isLastCompiland, intfs, lexbuf, tripleSlashComments) - else - if lexbuf.SupportsFeature LanguageFeature.MLCompatRevisions then - error(Error(FSComp.SR.buildInvalidSourceFileExtensionUpdated fileName, rangeStartup)) - else - error(Error(FSComp.SR.buildInvalidSourceFileExtension fileName, rangeStartup)) + let tripleSlashComments = + LexbufLocalXmlDocStore.ReportInvalidXmlDocPositions(lexbuf) + + PostParseModuleSpecs(defaultNamespace, fileName, isLastCompiland, intfs, lexbuf, tripleSlashComments) + else if lexbuf.SupportsFeature LanguageFeature.MLCompatRevisions then + error (Error(FSComp.SR.buildInvalidSourceFileExtensionUpdated fileName, rangeStartup)) + else + error (Error(FSComp.SR.buildInvalidSourceFileExtension fileName, rangeStartup)) scopedPragmas <- GetScopedPragmasForInput input input finally // OK, now commit the errors, since the ScopedPragmas will (hopefully) have been scraped - let filteringDiagnosticsLogger = GetDiagnosticsLoggerFilteringByScopedPragmas(false, scopedPragmas, diagnosticOptions, diagnosticsLogger) + let filteringDiagnosticsLogger = + GetDiagnosticsLoggerFilteringByScopedPragmas(false, scopedPragmas, diagnosticOptions, diagnosticsLogger) + delayLogger.CommitDelayedDiagnostics filteringDiagnosticsLogger type Tokenizer = unit -> Parser.token @@ -320,35 +476,47 @@ let ShowAllTokensAndExit (shortFilename, tokenizer: Tokenizer, lexbuf: LexBuffer printf "tokenize - getting one token from %s\n" shortFilename let t = tokenizer () printf "tokenize - got %s @ %a\n" (Parser.token_to_string t) outputRange lexbuf.LexemeRange + match t with | Parser.EOF _ -> exit 0 | _ -> () - if lexbuf.IsPastEndOfStream then printf "!!! at end of stream\n" + + if lexbuf.IsPastEndOfStream then + printf "!!! at end of stream\n" // Test one of the parser entry points, just for testing purposes let TestInteractionParserAndExit (tokenizer: Tokenizer, lexbuf: LexBuffer) = while true do match (Parser.interaction (fun _ -> tokenizer ()) lexbuf) with - | ParsedScriptInteraction.Definitions(l, m) -> printfn "Parsed OK, got %d defs @ %a" l.Length outputRange m - | ParsedScriptInteraction.HashDirective(_, m) -> printfn "Parsed OK, got hash @ %a" outputRange m + | ParsedScriptInteraction.Definitions (l, m) -> printfn "Parsed OK, got %d defs @ %a" l.Length outputRange m + | ParsedScriptInteraction.HashDirective (_, m) -> printfn "Parsed OK, got hash @ %a" outputRange m + exit 0 // Report the statistics for testing purposes let ReportParsingStatistics res = let rec flattenSpecs specs = - specs |> List.collect (function SynModuleSigDecl.NestedModule (moduleDecls=subDecls) -> flattenSpecs subDecls | spec -> [spec]) + specs + |> List.collect (function + | SynModuleSigDecl.NestedModule (moduleDecls = subDecls) -> flattenSpecs subDecls + | spec -> [ spec ]) + let rec flattenDefns specs = - specs |> List.collect (function SynModuleDecl.NestedModule (decls=subDecls) -> flattenDefns subDecls | defn -> [defn]) + specs + |> List.collect (function + | SynModuleDecl.NestedModule (decls = subDecls) -> flattenDefns subDecls + | defn -> [ defn ]) + + let flattenModSpec (SynModuleOrNamespaceSig (decls = decls)) = flattenSpecs decls + let flattenModImpl (SynModuleOrNamespace (decls = decls)) = flattenDefns decls - let flattenModSpec (SynModuleOrNamespaceSig(decls = decls)) = flattenSpecs decls - let flattenModImpl (SynModuleOrNamespace(decls = decls)) = flattenDefns decls match res with | ParsedInput.SigFile (ParsedSigFileInput (modules = specs)) -> printfn "parsing yielded %d specs" (List.collect flattenModSpec specs).Length | ParsedInput.ImplFile (ParsedImplFileInput (modules = impls)) -> printfn "parsing yielded %d definitions" (List.collect flattenModImpl impls).Length -let EmptyParsedInput(fileName, isLastCompiland) = +let EmptyParsedInput (fileName, isLastCompiland) = if FSharpSigFileSuffixes |> List.exists (FileSystemUtils.checkSuffix fileName) then ParsedInput.SigFile( ParsedSigFileInput( @@ -357,7 +525,10 @@ let EmptyParsedInput(fileName, isLastCompiland) = [], [], [], - { ConditionalDirectives = []; CodeComments = [] } + { + ConditionalDirectives = [] + CodeComments = [] + } ) ) else @@ -370,23 +541,29 @@ let EmptyParsedInput(fileName, isLastCompiland) = [], [], isLastCompiland, - { ConditionalDirectives = []; CodeComments = [] } + { + ConditionalDirectives = [] + CodeComments = [] + } ) ) /// Parse an input, drawing tokens from the LexBuffer let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) = use unwindbuildphase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse + try // Don't report whitespace from lexer let skipWhitespaceTokens = true // Set up the initial status for indentation-aware processing - let indentationSyntaxStatus = IndentationAwareSyntaxStatus (tcConfig.ComputeIndentationAwareSyntaxInitialStatus fileName, true) + let indentationSyntaxStatus = + IndentationAwareSyntaxStatus(tcConfig.ComputeIndentationAwareSyntaxInitialStatus fileName, true) // Set up the initial lexer arguments - let lexargs = mkLexargs (tcConfig.conditionalDefines, indentationSyntaxStatus, lexResourceManager, [], diagnosticsLogger, tcConfig.pathMap) + let lexargs = + mkLexargs (tcConfig.conditionalDefines, indentationSyntaxStatus, lexResourceManager, [], diagnosticsLogger, tcConfig.pathMap) // Set up the initial lexer arguments let shortFilename = SanitizeFileName fileName tcConfig.implicitIncludeDir @@ -395,14 +572,29 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam usingLexbufForParsing (lexbuf, fileName) (fun lexbuf -> // Set up the LexFilter over the token stream - let tokenizer,tokenizeOnly = + let tokenizer, tokenizeOnly = match tcConfig.tokenize with - | TokenizeOption.Unfiltered -> - (fun () -> Lexer.token lexargs skipWhitespaceTokens lexbuf), true + | TokenizeOption.Unfiltered -> (fun () -> Lexer.token lexargs skipWhitespaceTokens lexbuf), true | TokenizeOption.Only -> - LexFilter.LexFilter(indentationSyntaxStatus, tcConfig.compilingFSharpCore, Lexer.token lexargs skipWhitespaceTokens, lexbuf).GetToken, true + LexFilter + .LexFilter( + indentationSyntaxStatus, + tcConfig.compilingFSharpCore, + Lexer.token lexargs skipWhitespaceTokens, + lexbuf + ) + .GetToken, + true | _ -> - LexFilter.LexFilter(indentationSyntaxStatus, tcConfig.compilingFSharpCore, Lexer.token lexargs skipWhitespaceTokens, lexbuf).GetToken, false + LexFilter + .LexFilter( + indentationSyntaxStatus, + tcConfig.compilingFSharpCore, + Lexer.token lexargs skipWhitespaceTokens, + lexbuf + ) + .GetToken, + false // If '--tokenize' then show the tokens now and exit if tokenizeOnly then @@ -410,44 +602,71 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam // Test hook for one of the parser entry points if tcConfig.testInteractionParser then - TestInteractionParserAndExit (tokenizer, lexbuf) + TestInteractionParserAndExit(tokenizer, lexbuf) // Parse the input - let res = ParseInput((fun _ -> tokenizer ()), tcConfig.diagnosticsOptions, diagnosticsLogger, lexbuf, None, fileName, isLastCompiland) + let res = + ParseInput( + (fun _ -> tokenizer ()), + tcConfig.diagnosticsOptions, + diagnosticsLogger, + lexbuf, + None, + fileName, + isLastCompiland + ) // Report the statistics for testing purposes - if tcConfig.reportNumDecls then - ReportParsingStatistics res + if tcConfig.reportNumDecls then ReportParsingStatistics res + + res) - res - ) input with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) -let ValidSuffixes = FSharpSigFileSuffixes@FSharpImplFileSuffixes +let ValidSuffixes = FSharpSigFileSuffixes @ FSharpImplFileSuffixes let checkInputFile (tcConfig: TcConfig) fileName = if List.exists (FileSystemUtils.checkSuffix fileName) ValidSuffixes then - if not(FileSystem.FileExistsShim fileName) then - error(Error(FSComp.SR.buildCouldNotFindSourceFile fileName, rangeStartup)) + if not (FileSystem.FileExistsShim fileName) then + error (Error(FSComp.SR.buildCouldNotFindSourceFile fileName, rangeStartup)) else - error(Error(FSComp.SR.buildInvalidSourceFileExtension(SanitizeFileName fileName tcConfig.implicitIncludeDir), rangeStartup)) + error (Error(FSComp.SR.buildInvalidSourceFileExtension (SanitizeFileName fileName tcConfig.implicitIncludeDir), rangeStartup)) -let parseInputStreamAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream: Stream) = +let parseInputStreamAux + ( + tcConfig: TcConfig, + lexResourceManager, + fileName, + isLastCompiland, + diagnosticsLogger, + retryLocked, + stream: Stream + ) = use reader = stream.GetReader(tcConfig.inputCodePage, retryLocked) // Set up the LexBuffer for the file - let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, reader) + let lexbuf = + UnicodeLexing.StreamReaderAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, reader) // Parse the file drawing tokens from the lexbuf ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) -let parseInputSourceTextAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText: ISourceText) = +let parseInputSourceTextAux + ( + tcConfig: TcConfig, + lexResourceManager, + fileName, + isLastCompiland, + diagnosticsLogger, + sourceText: ISourceText + ) = // Set up the LexBuffer for the file - let lexbuf = UnicodeLexing.SourceTextAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, sourceText) + let lexbuf = + UnicodeLexing.SourceTextAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, sourceText) // Parse the file drawing tokens from the lexbuf ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) @@ -458,23 +677,41 @@ let parseInputFileAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastC use reader = fileStream.GetReader(tcConfig.inputCodePage, retryLocked) // Set up the LexBuffer for the file - let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, reader) + let lexbuf = + UnicodeLexing.StreamReaderAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, reader) // Parse the file drawing tokens from the lexbuf ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) /// Parse an input from stream -let ParseOneInputStream (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream: Stream) = +let ParseOneInputStream + ( + tcConfig: TcConfig, + lexResourceManager, + fileName, + isLastCompiland, + diagnosticsLogger, + retryLocked, + stream: Stream + ) = try - parseInputStreamAux(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream) + parseInputStreamAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream) with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) /// Parse an input from source text -let ParseOneInputSourceText (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText: ISourceText) = +let ParseOneInputSourceText + ( + tcConfig: TcConfig, + lexResourceManager, + fileName, + isLastCompiland, + diagnosticsLogger, + sourceText: ISourceText + ) = try - parseInputSourceTextAux(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText) + parseInputSourceTextAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText) with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -482,31 +719,43 @@ let ParseOneInputSourceText (tcConfig: TcConfig, lexResourceManager, fileName, i /// Parse an input from disk let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) = try - checkInputFile tcConfig fileName - parseInputFileAux(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) + checkInputFile tcConfig fileName + parseInputFileAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) /// Parse multiple input files from disk -let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, diagnosticsLogger: DiagnosticsLogger, exiter: Exiter, createDiagnosticsLogger: Exiter -> CapturingDiagnosticsLogger, retryLocked) = +let ParseInputFiles + ( + tcConfig: TcConfig, + lexResourceManager, + sourceFiles, + diagnosticsLogger: DiagnosticsLogger, + exiter: Exiter, + createDiagnosticsLogger: Exiter -> CapturingDiagnosticsLogger, + retryLocked + ) = try let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint let sourceFiles = isLastCompiland |> List.zip sourceFiles |> Array.ofList if tcConfig.concurrentBuild then let mutable exitCode = 0 + let delayedExiter = { new Exiter with - member _.Exit n = exitCode <- n; raise StopProcessing } + member _.Exit n = + exitCode <- n + raise StopProcessing + } // Check input files and create delayed error loggers before we try to parallel parse. let delayedDiagnosticsLoggers = sourceFiles |> Array.map (fun (fileName, _) -> checkInputFile tcConfig fileName - createDiagnosticsLogger(delayedExiter) - ) + createDiagnosticsLogger (delayedExiter)) let results = try @@ -516,25 +765,33 @@ let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, diagno let delayedDiagnosticsLogger = delayedDiagnosticsLoggers[i] let directoryName = Path.GetDirectoryName fileName - let input = parseInputFileAux(tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), delayedDiagnosticsLogger, retryLocked) - (input, directoryName) - ) + + let input = + parseInputFileAux ( + tcConfig, + lexResourceManager, + fileName, + (isLastCompiland, isExe), + delayedDiagnosticsLogger, + retryLocked + ) + + (input, directoryName)) finally delayedDiagnosticsLoggers - |> Array.iter (fun delayedDiagnosticsLogger -> - delayedDiagnosticsLogger.CommitDelayedDiagnostics diagnosticsLogger - ) - with - | StopProcessing -> + |> Array.iter (fun delayedDiagnosticsLogger -> delayedDiagnosticsLogger.CommitDelayedDiagnostics diagnosticsLogger) + with StopProcessing -> exiter.Exit exitCode - results - |> List.ofArray + results |> List.ofArray else sourceFiles |> Array.map (fun (fileName, isLastCompiland) -> let directoryName = Path.GetDirectoryName fileName - let input = ParseOneInputFile(tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), diagnosticsLogger, retryLocked) + + let input = + ParseOneInputFile(tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), diagnosticsLogger, retryLocked) + (input, directoryName)) |> List.ofArray @@ -543,13 +800,11 @@ let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, diagno exiter.Exit 1 let ProcessMetaCommandsFromInput - (nowarnF: 'state -> range * string -> 'state, - hashReferenceF: 'state -> range * string * Directive -> 'state, - loadSourceF: 'state -> range * string -> unit) - (tcConfig:TcConfigBuilder, - inp: ParsedInput, - pathOfMetaCommandSource, - state0) = + (nowarnF: 'state -> range * string -> 'state, + hashReferenceF: 'state -> range * string * Directive -> 'state, + loadSourceF: 'state -> range * string -> unit) + (tcConfig: TcConfigBuilder, inp: ParsedInput, pathOfMetaCommandSource, state0) + = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse @@ -560,105 +815,118 @@ let ProcessMetaCommandsFromInput let ProcessDependencyManagerDirective directive args m state = if not canHaveScriptMetaCommands then - errorR(HashReferenceNotAllowedInNonScript m) + errorR (HashReferenceNotAllowedInNonScript m) match args with - | [path] -> - let p = - if String.IsNullOrWhiteSpace(path) then "" - else path + | [ path ] -> + let p = if String.IsNullOrWhiteSpace(path) then "" else path hashReferenceF state (m, p, directive) | _ -> - errorR(Error(FSComp.SR.buildInvalidHashrDirective(), m)) + errorR (Error(FSComp.SR.buildInvalidHashrDirective (), m)) state let ProcessMetaCommand state hash = let mutable matchedm = range0 + try match hash with - | ParsedHashDirective("I", ParsedHashDirectiveArguments args, m) -> + | ParsedHashDirective ("I", ParsedHashDirectiveArguments args, m) -> if not canHaveScriptMetaCommands then - errorR(HashIncludeNotAllowedInNonScript m) + errorR (HashIncludeNotAllowedInNonScript m) + match args with - | [path] -> + | [ path ] -> matchedm <- m tcConfig.AddIncludePath(m, path, pathOfMetaCommandSource) state | _ -> - errorR(Error(FSComp.SR.buildInvalidHashIDirective(), m)) + errorR (Error(FSComp.SR.buildInvalidHashIDirective (), m)) state - | ParsedHashDirective("nowarn", ParsedHashDirectiveArguments numbers,m) -> - List.fold (fun state d -> nowarnF state (m,d)) state numbers - - | ParsedHashDirective(("reference" | "r"), ParsedHashDirectiveArguments args, m) -> - matchedm<-m + | ParsedHashDirective ("nowarn", ParsedHashDirectiveArguments numbers, m) -> + List.fold (fun state d -> nowarnF state (m, d)) state numbers + + | ParsedHashDirective (("reference" + | "r"), + ParsedHashDirectiveArguments args, + m) -> + matchedm <- m ProcessDependencyManagerDirective Directive.Resolution args m state - | ParsedHashDirective("i", ParsedHashDirectiveArguments args, m) -> - matchedm<-m + | ParsedHashDirective ("i", ParsedHashDirectiveArguments args, m) -> + matchedm <- m ProcessDependencyManagerDirective Directive.Include args m state - | ParsedHashDirective("load", ParsedHashDirectiveArguments args, m) -> + | ParsedHashDirective ("load", ParsedHashDirectiveArguments args, m) -> if not canHaveScriptMetaCommands then - errorR(HashDirectiveNotAllowedInNonScript m) + errorR (HashDirectiveNotAllowedInNonScript m) + match args with | _ :: _ -> - matchedm<-m - args |> List.iter (fun path -> loadSourceF state (m, path)) - | _ -> - errorR(Error(FSComp.SR.buildInvalidHashloadDirective(), m)) + matchedm <- m + args |> List.iter (fun path -> loadSourceF state (m, path)) + | _ -> errorR (Error(FSComp.SR.buildInvalidHashloadDirective (), m)) + state - | ParsedHashDirective("time", ParsedHashDirectiveArguments args, m) -> + | ParsedHashDirective ("time", ParsedHashDirectiveArguments args, m) -> if not canHaveScriptMetaCommands then - errorR(HashDirectiveNotAllowedInNonScript m) + errorR (HashDirectiveNotAllowedInNonScript m) + match args with - | [] -> - () - | ["on" | "off"] -> - () - | _ -> - errorR(Error(FSComp.SR.buildInvalidHashtimeDirective(), m)) + | [] -> () + | [ "on" | "off" ] -> () + | _ -> errorR (Error(FSComp.SR.buildInvalidHashtimeDirective (), m)) + state | _ -> (* warning(Error("This meta-command has been ignored", m)) *) state - with e -> errorRecovery e matchedm; state + with e -> + errorRecovery e matchedm + state let rec WarnOnIgnoredSpecDecls decls = - decls |> List.iter (fun d -> + decls + |> List.iter (fun d -> match d with - | SynModuleSigDecl.HashDirective (_, m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(), m)) - | SynModuleSigDecl.NestedModule (moduleDecls=subDecls) -> WarnOnIgnoredSpecDecls subDecls + | SynModuleSigDecl.HashDirective (_, m) -> warning (Error(FSComp.SR.buildDirectivesInModulesAreIgnored (), m)) + | SynModuleSigDecl.NestedModule (moduleDecls = subDecls) -> WarnOnIgnoredSpecDecls subDecls | _ -> ()) let rec WarnOnIgnoredImplDecls decls = - decls |> List.iter (fun d -> + decls + |> List.iter (fun d -> match d with - | SynModuleDecl.HashDirective (_, m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(), m)) - | SynModuleDecl.NestedModule (decls=subDecls) -> WarnOnIgnoredImplDecls subDecls + | SynModuleDecl.HashDirective (_, m) -> warning (Error(FSComp.SR.buildDirectivesInModulesAreIgnored (), m)) + | SynModuleDecl.NestedModule (decls = subDecls) -> WarnOnIgnoredImplDecls subDecls | _ -> ()) - let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig(decls = decls)) = - List.fold (fun s d -> - match d with - | SynModuleSigDecl.HashDirective (h, _) -> ProcessMetaCommand s h - | SynModuleSigDecl.NestedModule (moduleDecls=subDecls) -> WarnOnIgnoredSpecDecls subDecls; s - | _ -> s) - state - decls - - let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace(decls = decls)) = - List.fold (fun s d -> - match d with - | SynModuleDecl.HashDirective (h, _) -> ProcessMetaCommand s h - | SynModuleDecl.NestedModule (decls=subDecls) -> WarnOnIgnoredImplDecls subDecls; s - | _ -> s) - state - decls + let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig (decls = decls)) = + List.fold + (fun s d -> + match d with + | SynModuleSigDecl.HashDirective (h, _) -> ProcessMetaCommand s h + | SynModuleSigDecl.NestedModule (moduleDecls = subDecls) -> + WarnOnIgnoredSpecDecls subDecls + s + | _ -> s) + state + decls + + let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace (decls = decls)) = + List.fold + (fun s d -> + match d with + | SynModuleDecl.HashDirective (h, _) -> ProcessMetaCommand s h + | SynModuleDecl.NestedModule (decls = subDecls) -> + WarnOnIgnoredImplDecls subDecls + s + | _ -> s) + state + decls match inp with | ParsedInput.SigFile (ParsedSigFileInput (hashDirectives = hashDirectives; modules = specs)) -> @@ -673,24 +941,25 @@ let ProcessMetaCommandsFromInput let ApplyNoWarnsToTcConfig (tcConfig: TcConfig, inp: ParsedInput, pathOfMetaCommandSource) = // Clone let tcConfigB = tcConfig.CloneToBuilder() - let addNoWarn = fun () (m,s) -> tcConfigB.TurnWarningOff(m, s) + let addNoWarn = fun () (m, s) -> tcConfigB.TurnWarningOff(m, s) let addReference = fun () (_m, _s, _) -> () let addLoadedSource = fun () (_m, _s) -> () - ProcessMetaCommandsFromInput - (addNoWarn, addReference, addLoadedSource) - (tcConfigB, inp, pathOfMetaCommandSource, ()) - TcConfig.Create(tcConfigB, validate=false) + ProcessMetaCommandsFromInput (addNoWarn, addReference, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) + TcConfig.Create(tcConfigB, validate = false) let ApplyMetaCommandsFromInputToTcConfig (tcConfig: TcConfig, inp: ParsedInput, pathOfMetaCommandSource, dependencyProvider) = // Clone let tcConfigB = tcConfig.CloneToBuilder() let getWarningNumber = fun () _ -> () - let addReferenceDirective = fun () (m, path, directive) -> tcConfigB.AddReferenceDirective(dependencyProvider, m, path, directive) - let addLoadedSource = fun () (m,s) -> tcConfigB.AddLoadedSource(m,s,pathOfMetaCommandSource) - ProcessMetaCommandsFromInput - (getWarningNumber, addReferenceDirective, addLoadedSource) - (tcConfigB, inp, pathOfMetaCommandSource, ()) - TcConfig.Create(tcConfigB, validate=false) + + let addReferenceDirective = + fun () (m, path, directive) -> tcConfigB.AddReferenceDirective(dependencyProvider, m, path, directive) + + let addLoadedSource = + fun () (m, s) -> tcConfigB.AddLoadedSource(m, s, pathOfMetaCommandSource) + + ProcessMetaCommandsFromInput (getWarningNumber, addReferenceDirective, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) + TcConfig.Create(tcConfigB, validate = false) /// Build the initial type checking environment let GetInitialTcEnv (assemblyName: string, initm: range, tcConfig: TcConfig, tcImports: TcImports, tcGlobals) = @@ -702,12 +971,17 @@ let GetInitialTcEnv (assemblyName: string, initm: range, tcConfig: TcConfig, tcI let amap = tcImports.GetImportMap() - let openDecls0, tcEnv = CreateInitialTcEnv(tcGlobals, amap, initm, assemblyName, ccus) + let openDecls0, tcEnv = + CreateInitialTcEnv(tcGlobals, amap, initm, assemblyName, ccus) if tcConfig.checkOverflow then - try - let checkOperatorsModule = pathToSynLid initm (splitNamespace CoreOperatorsCheckedName) - let tcEnv, openDecls1 = TcOpenModuleOrNamespaceDecl TcResultsSink.NoSink tcGlobals amap initm tcEnv (checkOperatorsModule, initm) + try + let checkOperatorsModule = + pathToSynLid initm (splitNamespace CoreOperatorsCheckedName) + + let tcEnv, openDecls1 = + TcOpenModuleOrNamespaceDecl TcResultsSink.NoSink tcGlobals amap initm tcEnv (checkOperatorsModule, initm) + tcEnv, openDecls0 @ openDecls1 with e -> errorRecovery e initm @@ -716,27 +990,27 @@ let GetInitialTcEnv (assemblyName: string, initm: range, tcConfig: TcConfig, tcI tcEnv, openDecls0 /// Inject faults into checking -let CheckSimulateException(tcConfig: TcConfig) = +let CheckSimulateException (tcConfig: TcConfig) = match tcConfig.simulateException with - | Some("tc-oom") -> raise(OutOfMemoryException()) - | Some("tc-an") -> raise(ArgumentNullException("simulated")) - | Some("tc-invop") -> raise(InvalidOperationException()) - | Some("tc-av") -> raise(AccessViolationException()) - | Some("tc-nfn") -> raise(NotFiniteNumberException()) - | Some("tc-aor") -> raise(ArgumentOutOfRangeException()) - | Some("tc-dv0") -> raise(DivideByZeroException()) - | Some("tc-oe") -> raise(OverflowException()) - | Some("tc-atmm") -> raise(ArrayTypeMismatchException()) - | Some("tc-bif") -> raise(BadImageFormatException()) - | Some("tc-knf") -> raise(KeyNotFoundException()) - | Some("tc-ior") -> raise(IndexOutOfRangeException()) - | Some("tc-ic") -> raise(InvalidCastException()) - | Some("tc-ip") -> raise(InvalidProgramException()) - | Some("tc-ma") -> raise(MemberAccessException()) - | Some("tc-ni") -> raise(NotImplementedException()) - | Some("tc-nr") -> raise(NullReferenceException()) - | Some("tc-oc") -> raise(OperationCanceledException()) - | Some("tc-fail") -> failwith "simulated" + | Some ("tc-oom") -> raise (OutOfMemoryException()) + | Some ("tc-an") -> raise (ArgumentNullException("simulated")) + | Some ("tc-invop") -> raise (InvalidOperationException()) + | Some ("tc-av") -> raise (AccessViolationException()) + | Some ("tc-nfn") -> raise (NotFiniteNumberException()) + | Some ("tc-aor") -> raise (ArgumentOutOfRangeException()) + | Some ("tc-dv0") -> raise (DivideByZeroException()) + | Some ("tc-oe") -> raise (OverflowException()) + | Some ("tc-atmm") -> raise (ArrayTypeMismatchException()) + | Some ("tc-bif") -> raise (BadImageFormatException()) + | Some ("tc-knf") -> raise (KeyNotFoundException()) + | Some ("tc-ior") -> raise (IndexOutOfRangeException()) + | Some ("tc-ic") -> raise (InvalidCastException()) + | Some ("tc-ip") -> raise (InvalidProgramException()) + | Some ("tc-ma") -> raise (MemberAccessException()) + | Some ("tc-ni") -> raise (NotImplementedException()) + | Some ("tc-nr") -> raise (NullReferenceException()) + | Some ("tc-oc") -> raise (OperationCanceledException()) + | Some ("tc-fail") -> failwith "simulated" | _ -> () //---------------------------------------------------------------------------- @@ -745,24 +1019,24 @@ let CheckSimulateException(tcConfig: TcConfig) = type RootSigs = Zmap -type RootImpls = Zset +type RootImpls = Zset let qnameOrder = Order.orderBy (fun (q: QualifiedNameOfFile) -> q.Text) type TcState = { - tcsCcu: CcuThunk - tcsCcuType: ModuleOrNamespace - tcsNiceNameGen: NiceNameGenerator - tcsTcSigEnv: TcEnv - tcsTcImplEnv: TcEnv - tcsCreatesGeneratedProvidedTypes: bool - tcsRootSigs: RootSigs - tcsRootImpls: RootImpls - tcsCcuSig: ModuleOrNamespaceType - - /// The collected open declarations implied by '/checked' flag and processing F# interactive fragments that have an implied module. - tcsImplicitOpenDeclarations: OpenDeclaration list + tcsCcu: CcuThunk + tcsCcuType: ModuleOrNamespace + tcsNiceNameGen: NiceNameGenerator + tcsTcSigEnv: TcEnv + tcsTcImplEnv: TcEnv + tcsCreatesGeneratedProvidedTypes: bool + tcsRootSigs: RootSigs + tcsRootImpls: RootImpls + tcsCcuSig: ModuleOrNamespaceType + + /// The collected open declarations implied by '/checked' flag and processing F# interactive fragments that have an implied module. + tcsImplicitOpenDeclarations: OpenDeclaration list } member x.NiceNameGenerator = x.tcsNiceNameGen @@ -782,35 +1056,39 @@ type TcState = member x.CcuSig = x.tcsCcuSig member x.NextStateAfterIncrementalFragment tcEnvAtEndOfLastInput = - { x with tcsTcSigEnv = tcEnvAtEndOfLastInput - tcsTcImplEnv = tcEnvAtEndOfLastInput } - + { x with + tcsTcSigEnv = tcEnvAtEndOfLastInput + tcsTcImplEnv = tcEnvAtEndOfLastInput + } /// Create the initial type checking state for compiling an assembly -let GetInitialTcState(m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcImports, niceNameGen, tcEnv0, openDecls0) = +let GetInitialTcState (m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcImports, niceNameGen, tcEnv0, openDecls0) = ignore tcImports // Create a ccu to hold all the results of compilation - let ccuContents = Construct.NewCcuContents ILScopeRef.Local m ccuName (Construct.NewEmptyModuleOrNamespaceType Namespace) + let ccuContents = + Construct.NewCcuContents ILScopeRef.Local m ccuName (Construct.NewEmptyModuleOrNamespaceType Namespace) let ccuData: CcuData = - { IsFSharp=true - UsesFSharp20PlusQuotations=false + { + IsFSharp = true + UsesFSharp20PlusQuotations = false #if !NO_TYPEPROVIDERS - InvalidateEvent=(Event<_>()).Publish - IsProviderGenerated = false - ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) + InvalidateEvent = (Event<_>()).Publish + IsProviderGenerated = false + ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) #endif - TryGetILModuleDef = (fun () -> None) - FileName=None - Stamp = newStamp() - QualifiedName= None - SourceCodeDirectory = tcConfig.implicitIncludeDir - ILScopeRef=ILScopeRef.Local - Contents=ccuContents - MemberSignatureEquality= typeEquivAux EraseAll tcGlobals - TypeForwarders= CcuTypeForwarderTable.Empty - XmlDocumentationInfo = None } + TryGetILModuleDef = (fun () -> None) + FileName = None + Stamp = newStamp () + QualifiedName = None + SourceCodeDirectory = tcConfig.implicitIncludeDir + ILScopeRef = ILScopeRef.Local + Contents = ccuContents + MemberSignatureEquality = typeEquivAux EraseAll tcGlobals + TypeForwarders = CcuTypeForwarderTable.Empty + XmlDocumentationInfo = None + } let ccu = CcuThunk.Create(ccuName, ccuData) @@ -818,16 +1096,17 @@ let GetInitialTcState(m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcIm if tcConfig.compilingFSharpCore then tcGlobals.fslibCcu.Fixup ccu - { tcsCcu= ccu - tcsCcuType=ccuContents - tcsNiceNameGen=niceNameGen - tcsTcSigEnv=tcEnv0 - tcsTcImplEnv=tcEnv0 - tcsCreatesGeneratedProvidedTypes=false - tcsRootSigs = Zmap.empty qnameOrder - tcsRootImpls = Zset.empty qnameOrder - tcsCcuSig = Construct.NewEmptyModuleOrNamespaceType Namespace - tcsImplicitOpenDeclarations = openDecls0 + { + tcsCcu = ccu + tcsCcuType = ccuContents + tcsNiceNameGen = niceNameGen + tcsTcSigEnv = tcEnv0 + tcsTcImplEnv = tcEnv0 + tcsCreatesGeneratedProvidedTypes = false + tcsRootSigs = Zmap.empty qnameOrder + tcsRootImpls = Zset.empty qnameOrder + tcsCcuSig = Construct.NewEmptyModuleOrNamespaceType Namespace + tcsImplicitOpenDeclarations = openDecls0 } /// Dummy typed impl file that contains no definitions and is not used for emitting any kind of assembly. @@ -850,115 +1129,151 @@ let CheckOneInput cancellable { try - CheckSimulateException tcConfig - - let m = inp.Range - let amap = tcImports.GetImportMap() - match inp with - | ParsedInput.SigFile (ParsedSigFileInput (qualifiedNameOfFile = qualNameOfFile) as file) -> - - // Check if we've seen this top module signature before. - if Zmap.mem qualNameOfFile tcState.tcsRootSigs then - errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text), m.StartRange)) - - // Check if the implementation came first in compilation order - if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR(Error(FSComp.SR.buildImplementationAlreadyGivenDetail(qualNameOfFile.Text), m)) - - let conditionalDefines = - if tcConfig.noConditionalErasure then None else Some tcConfig.conditionalDefines - - // Typecheck the signature file - let! tcEnv, sigFileType, createsGeneratedProvidedTypes = - CheckOneSigFile (tcGlobals, tcState.tcsNiceNameGen, amap, tcState.tcsCcu, checkForErrors, conditionalDefines, tcSink, tcConfig.internalTestSpanStackReferring) tcState.tcsTcSigEnv file - - let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs - - // Add the signature to the signature env (unless it had an explicit signature) - let ccuSigForFile = CombineCcuContentFragments m [sigFileType; tcState.tcsCcuSig] - - // Open the prefixPath for fsi.exe - let tcEnv, _openDecls1 = - match prefixPathOpt with - | None -> tcEnv, [] - | Some prefixPath -> - let m = qualNameOfFile.Range - TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcEnv (prefixPath, m) - - let tcState = - { tcState with - tcsTcSigEnv=tcEnv - tcsTcImplEnv=tcState.tcsTcImplEnv - tcsRootSigs=rootSigs - tcsCreatesGeneratedProvidedTypes=tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes} - - return (tcEnv, EmptyTopAttrs, None, ccuSigForFile), tcState - - | ParsedInput.ImplFile (ParsedImplFileInput (qualifiedNameOfFile = qualNameOfFile) as file) -> - - // Check if we've got an interface for this fragment - let rootSigOpt = tcState.tcsRootSigs.TryFind qualNameOfFile - - // Check if we've already seen an implementation for this fragment - if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR(Error(FSComp.SR.buildImplementationAlreadyGiven(qualNameOfFile.Text), m)) - - let tcImplEnv = tcState.tcsTcImplEnv - - let conditionalDefines = - if tcConfig.noConditionalErasure then None else Some tcConfig.conditionalDefines - - let hadSig = rootSigOpt.IsSome + CheckSimulateException tcConfig + + let m = inp.Range + let amap = tcImports.GetImportMap() + + match inp with + | ParsedInput.SigFile (ParsedSigFileInput (qualifiedNameOfFile = qualNameOfFile) as file) -> + + // Check if we've seen this top module signature before. + if Zmap.mem qualNameOfFile tcState.tcsRootSigs then + errorR (Error(FSComp.SR.buildSignatureAlreadySpecified (qualNameOfFile.Text), m.StartRange)) + + // Check if the implementation came first in compilation order + if Zset.contains qualNameOfFile tcState.tcsRootImpls then + errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail (qualNameOfFile.Text), m)) + + let conditionalDefines = + if tcConfig.noConditionalErasure then + None + else + Some tcConfig.conditionalDefines + + // Typecheck the signature file + let! tcEnv, sigFileType, createsGeneratedProvidedTypes = + CheckOneSigFile + (tcGlobals, + tcState.tcsNiceNameGen, + amap, + tcState.tcsCcu, + checkForErrors, + conditionalDefines, + tcSink, + tcConfig.internalTestSpanStackReferring) + tcState.tcsTcSigEnv + file + + let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs + + // Add the signature to the signature env (unless it had an explicit signature) + let ccuSigForFile = CombineCcuContentFragments m [ sigFileType; tcState.tcsCcuSig ] + + // Open the prefixPath for fsi.exe + let tcEnv, _openDecls1 = + match prefixPathOpt with + | None -> tcEnv, [] + | Some prefixPath -> + let m = qualNameOfFile.Range + TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcEnv (prefixPath, m) + + let tcState = + { tcState with + tcsTcSigEnv = tcEnv + tcsTcImplEnv = tcState.tcsTcImplEnv + tcsRootSigs = rootSigs + tcsCreatesGeneratedProvidedTypes = tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes + } - // Typecheck the implementation file - let typeCheckOne = - if skipImplIfSigExists && hadSig then - (EmptyTopAttrs, CreateEmptyDummyImplFile qualNameOfFile rootSigOpt.Value, Unchecked.defaultof<_>, tcImplEnv, false) - |> Cancellable.ret - else - CheckOneImplFile (tcGlobals, tcState.tcsNiceNameGen, amap, tcState.tcsCcu, tcState.tcsImplicitOpenDeclarations, checkForErrors, conditionalDefines, tcSink, tcConfig.internalTestSpanStackReferring, tcImplEnv, rootSigOpt, file) + return (tcEnv, EmptyTopAttrs, None, ccuSigForFile), tcState + + | ParsedInput.ImplFile (ParsedImplFileInput (qualifiedNameOfFile = qualNameOfFile) as file) -> + + // Check if we've got an interface for this fragment + let rootSigOpt = tcState.tcsRootSigs.TryFind qualNameOfFile + + // Check if we've already seen an implementation for this fragment + if Zset.contains qualNameOfFile tcState.tcsRootImpls then + errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (qualNameOfFile.Text), m)) + + let tcImplEnv = tcState.tcsTcImplEnv + + let conditionalDefines = + if tcConfig.noConditionalErasure then + None + else + Some tcConfig.conditionalDefines + + let hadSig = rootSigOpt.IsSome + + // Typecheck the implementation file + let typeCheckOne = + if skipImplIfSigExists && hadSig then + (EmptyTopAttrs, CreateEmptyDummyImplFile qualNameOfFile rootSigOpt.Value, Unchecked.defaultof<_>, tcImplEnv, false) + |> Cancellable.ret + else + CheckOneImplFile( + tcGlobals, + tcState.tcsNiceNameGen, + amap, + tcState.tcsCcu, + tcState.tcsImplicitOpenDeclarations, + checkForErrors, + conditionalDefines, + tcSink, + tcConfig.internalTestSpanStackReferring, + tcImplEnv, + rootSigOpt, + file + ) - let! topAttrs, implFile, _implFileHiddenType, tcEnvAtEnd, createsGeneratedProvidedTypes = typeCheckOne + let! topAttrs, implFile, _implFileHiddenType, tcEnvAtEnd, createsGeneratedProvidedTypes = typeCheckOne - let implFileSigType = implFile.Signature + let implFileSigType = implFile.Signature - let rootImpls = Zset.add qualNameOfFile tcState.tcsRootImpls + let rootImpls = Zset.add qualNameOfFile tcState.tcsRootImpls - // Only add it to the environment if it didn't have a signature - let m = qualNameOfFile.Range + // Only add it to the environment if it didn't have a signature + let m = qualNameOfFile.Range - // Add the implementation as to the implementation env - let tcImplEnv = AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcImplEnv implFileSigType + // Add the implementation as to the implementation env + let tcImplEnv = + AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcImplEnv implFileSigType - // Add the implementation as to the signature env (unless it had an explicit signature) - let tcSigEnv = - if hadSig then tcState.tcsTcSigEnv - else AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv implFileSigType + // Add the implementation as to the signature env (unless it had an explicit signature) + let tcSigEnv = + if hadSig then + tcState.tcsTcSigEnv + else + AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv implFileSigType - // Open the prefixPath for fsi.exe (tcImplEnv) - let tcImplEnv, openDecls = - match prefixPathOpt with - | Some prefixPath -> TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcImplEnv (prefixPath, m) - | _ -> tcImplEnv, [] + // Open the prefixPath for fsi.exe (tcImplEnv) + let tcImplEnv, openDecls = + match prefixPathOpt with + | Some prefixPath -> TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcImplEnv (prefixPath, m) + | _ -> tcImplEnv, [] - // Open the prefixPath for fsi.exe (tcSigEnv) - let tcSigEnv, _ = - match prefixPathOpt with - | Some prefixPath when not hadSig -> TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcSigEnv (prefixPath, m) - | _ -> tcSigEnv, [] + // Open the prefixPath for fsi.exe (tcSigEnv) + let tcSigEnv, _ = + match prefixPathOpt with + | Some prefixPath when not hadSig -> TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcSigEnv (prefixPath, m) + | _ -> tcSigEnv, [] - let ccuSigForFile = CombineCcuContentFragments m [implFileSigType; tcState.tcsCcuSig] + let ccuSigForFile = + CombineCcuContentFragments m [ implFileSigType; tcState.tcsCcuSig ] - let tcState = - { tcState with - tcsTcSigEnv=tcSigEnv - tcsTcImplEnv=tcImplEnv - tcsRootImpls=rootImpls - tcsCcuSig=ccuSigForFile - tcsCreatesGeneratedProvidedTypes=tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes + let tcState = + { tcState with + tcsTcSigEnv = tcSigEnv + tcsTcImplEnv = tcImplEnv + tcsRootImpls = rootImpls + tcsCcuSig = ccuSigForFile + tcsCreatesGeneratedProvidedTypes = tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes tcsImplicitOpenDeclarations = tcState.tcsImplicitOpenDeclarations @ openDecls } - return (tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile), tcState + + return (tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile), tcState with e -> errorRecovery e range0 @@ -966,48 +1281,65 @@ let CheckOneInput } /// Typecheck a single file (or interactive entry into F# Interactive) -let TypeCheckOneInputEntry (ctok, checkForErrors, tcConfig:TcConfig, tcImports, tcGlobals, prefixPathOpt) tcState inp = +let TypeCheckOneInputEntry (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt) tcState inp = // 'use' ensures that the warning handler is restored at the end - use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun oldLogger -> GetDiagnosticsLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput inp, tcConfig.diagnosticsOptions, oldLogger) ) + use unwindEL = + PushDiagnosticsLoggerPhaseUntilUnwind(fun oldLogger -> + GetDiagnosticsLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput inp, tcConfig.diagnosticsOptions, oldLogger)) + use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck RequireCompilationThread ctok - CheckOneInput (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, inp, false) - |> Cancellable.runWithoutCancellation + + CheckOneInput(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, inp, false) + |> Cancellable.runWithoutCancellation /// Finish checking multiple files (or one interactive entry into F# Interactive) -let CheckMultipleInputsFinish(results, tcState: TcState) = +let CheckMultipleInputsFinish (results, tcState: TcState) = let tcEnvsAtEndFile, topAttrs, implFiles, ccuSigsForFiles = List.unzip4 results let topAttrs = List.foldBack CombineTopAttrs topAttrs EmptyTopAttrs let implFiles = List.choose id implFiles // This is the environment required by fsi.exe when incrementally adding definitions - let tcEnvAtEndOfLastFile = (match tcEnvsAtEndFile with h :: _ -> h | _ -> tcState.TcEnvFromSignatures) + let tcEnvAtEndOfLastFile = + (match tcEnvsAtEndFile with + | h :: _ -> h + | _ -> tcState.TcEnvFromSignatures) + (tcEnvAtEndOfLastFile, topAttrs, implFiles, ccuSigsForFiles), tcState -let CheckOneInputAndFinish(checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) = +let CheckOneInputAndFinish (checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) = cancellable { Logger.LogBlockStart LogCompilerFunctionId.CompileOps_TypeCheckOneInputAndFinishEventually let! results, tcState = CheckOneInput(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input, false) - let result = CheckMultipleInputsFinish([results], tcState) + let result = CheckMultipleInputsFinish([ results ], tcState) Logger.LogBlockStop LogCompilerFunctionId.CompileOps_TypeCheckOneInputAndFinishEventually return result } let CheckClosedInputSetFinish (declaredImpls: CheckedImplFile list, tcState) = // Latest contents to the CCU - let ccuContents = Construct.NewCcuContents ILScopeRef.Local range0 tcState.tcsCcu.AssemblyName tcState.tcsCcuSig + let ccuContents = + Construct.NewCcuContents ILScopeRef.Local range0 tcState.tcsCcu.AssemblyName tcState.tcsCcuSig // Check all interfaces have implementations - tcState.tcsRootSigs |> Zmap.iter (fun qualNameOfFile _ -> - if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then - errorR(Error(FSComp.SR.buildSignatureWithoutImplementation(qualNameOfFile.Text), qualNameOfFile.Range))) + tcState.tcsRootSigs + |> Zmap.iter (fun qualNameOfFile _ -> + if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then + errorR (Error(FSComp.SR.buildSignatureWithoutImplementation (qualNameOfFile.Text), qualNameOfFile.Range))) tcState, declaredImpls, ccuContents let CheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions - let results, tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInputEntry (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) - let (tcEnvAtEndOfLastFile, topAttrs, implFiles, _), tcState = CheckMultipleInputsFinish(results, tcState) - let tcState, declaredImpls, ccuContents = CheckClosedInputSetFinish (implFiles, tcState) + let results, tcState = + (tcState, inputs) + ||> List.mapFold (TypeCheckOneInputEntry(ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) + + let (tcEnvAtEndOfLastFile, topAttrs, implFiles, _), tcState = + CheckMultipleInputsFinish(results, tcState) + + let tcState, declaredImpls, ccuContents = + CheckClosedInputSetFinish(implFiles, tcState) + tcState.Ccu.Deref.Contents <- ccuContents tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile diff --git a/src/Compiler/Driver/ScriptClosure.fs b/src/Compiler/Driver/ScriptClosure.fs index 7351edde58f..67adfb1e8de 100644 --- a/src/Compiler/Driver/ScriptClosure.fs +++ b/src/Compiler/Driver/ScriptClosure.fs @@ -73,26 +73,20 @@ type LoadClosure = LoadClosureRootFileDiagnostics: (PhasedDiagnostic * FSharpDiagnosticSeverity) list } - [] type CodeContext = | CompilationAndEvaluation // in fsi.exe - | Compilation // in fsc.exe + | Compilation // in fsc.exe | Editing // in VS module ScriptPreprocessClosure = /// Represents an input to the closure finding process - type ClosureSource = - ClosureSource of - fileName: string * - referenceRange: range * - sourceText: ISourceText * - parseRequired: bool + type ClosureSource = ClosureSource of fileName: string * referenceRange: range * sourceText: ISourceText * parseRequired: bool /// Represents an output of the closure finding process type ClosureFile = - ClosureFile of + | ClosureFile of fileName: string * range: range * parsedInput: ParsedInput option * @@ -102,12 +96,11 @@ module ScriptPreprocessClosure = type Observed() = let seen = Dictionary<_, bool>() + member _.SetSeen check = - if not(seen.ContainsKey check) then - seen.Add(check, true) + if not (seen.ContainsKey check) then seen.Add(check, true) - member _.HaveSeen check = - seen.ContainsKey check + member _.HaveSeen check = seen.ContainsKey check /// Parse a script file (or any input file referenced by '#load') let ParseScriptClosureInput @@ -127,19 +120,25 @@ module ScriptPreprocessClosure = // .fsx -- EDITING + !COMPILED\INTERACTIVE let defines = match codeContext with - | CodeContext.CompilationAndEvaluation -> ["INTERACTIVE"] - | CodeContext.Compilation -> ["COMPILED"] - | CodeContext.Editing -> "EDITING" :: (if IsScript fileName then ["INTERACTIVE"] else ["COMPILED"]) + | CodeContext.CompilationAndEvaluation -> [ "INTERACTIVE" ] + | CodeContext.Compilation -> [ "COMPILED" ] + | CodeContext.Editing -> + "EDITING" + :: (if IsScript fileName then + [ "INTERACTIVE" ] + else + [ "COMPILED" ]) - let tcConfigB = tcConfig.CloneToBuilder() + let tcConfigB = tcConfig.CloneToBuilder() tcConfigB.conditionalDefines <- defines @ tcConfig.conditionalDefines let tcConfig = TcConfig.Create(tcConfigB, false) - - let lexbuf = UnicodeLexing.SourceTextAsLexbuf(true, tcConfig.langVersion, sourceText) + + let lexbuf = + UnicodeLexing.SourceTextAsLexbuf(true, tcConfig.langVersion, sourceText) // The root compiland is last in the list of compilands. let isLastCompiland = (IsScript fileName, tcConfig.target.IsExe) - ParseOneInputLexbuf (tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) + ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) /// Create a TcConfig for load closure starting from a single .fsx file let CreateScriptTextTcConfig @@ -164,8 +163,10 @@ module ScriptPreprocessClosure = let isInvalidationSupported = (codeContext = CodeContext.Editing) let rangeForErrors = mkFirstLineOfFile fileName + let tcConfigB = - TcConfigBuilder.CreateNew(legacyReferenceResolver, + TcConfigBuilder.CreateNew( + legacyReferenceResolver, defaultFSharpBinariesDir, reduceMemoryUsage, projectDir, @@ -174,8 +175,16 @@ module ScriptPreprocessClosure = CopyFSharpCoreFlag.No, tryGetMetadataSnapshot, sdkDirOverride, - rangeForErrors) - tcConfigB.SetPrimaryAssembly (if assumeDotNetFramework then PrimaryAssembly.Mscorlib else PrimaryAssembly.System_Runtime) + rangeForErrors + ) + + let primaryAssembly = + if assumeDotNetFramework then + PrimaryAssembly.Mscorlib + else + PrimaryAssembly.System_Runtime + + tcConfigB.SetPrimaryAssembly primaryAssembly tcConfigB.SetUseSdkRefs useSdkRefs applyCommandLineArgs tcConfigB @@ -186,13 +195,21 @@ module ScriptPreprocessClosure = match basicReferences with | None -> let diagnosticsLogger = CapturingDiagnosticsLogger("ScriptDefaultReferences") - use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) - let references, useDotNetFramework = tcConfigB.FxResolver.GetDefaultReferences useFsiAuxLib + use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) + + let references, useDotNetFramework = + tcConfigB.FxResolver.GetDefaultReferences useFsiAuxLib // If the user requested .NET Core scripting but something went wrong and we reverted to // .NET Framework scripting then we must adjust both the primaryAssembly and fxResolver if useDotNetFramework <> assumeDotNetFramework then - tcConfigB.SetPrimaryAssembly (if useDotNetFramework then PrimaryAssembly.Mscorlib else PrimaryAssembly.System_Runtime) + let primaryAssembly = + if useDotNetFramework then + PrimaryAssembly.Mscorlib + else + PrimaryAssembly.System_Runtime + + tcConfigB.SetPrimaryAssembly primaryAssembly // Add script references for reference in references do @@ -203,6 +220,7 @@ module ScriptPreprocessClosure = | Some (rs, diagnostics) -> for m, reference in rs do tcConfigB.AddReferencedAssemblyByPath(m, reference) + diagnostics tcConfigB.resolutionEnvironment <- @@ -221,18 +239,20 @@ module ScriptPreprocessClosure = tcConfigB.SetUseSdkRefs useSdkRefs - TcConfig.Create(tcConfigB, validate=true), scriptDefaultReferencesDiagnostics + TcConfig.Create(tcConfigB, validate = true), scriptDefaultReferencesDiagnostics - let ClosureSourceOfFilename(fileName, m, inputCodePage, parseRequired) = + let ClosureSourceOfFilename (fileName, m, inputCodePage, parseRequired) = try let fileName = FileSystem.GetFullPathShim fileName use stream = FileSystem.OpenFileForReadShim(fileName) + use reader = match inputCodePage with | None -> new StreamReader(stream, true) | Some (n: int) -> new StreamReader(stream, Encoding.GetEncoding n) + let source = reader.ReadToEnd() - [ClosureSource(fileName, m, SourceText.ofString source, parseRequired)] + [ ClosureSource(fileName, m, SourceText.ofString source, parseRequired) ] with exn -> errorRecovery exn m [] @@ -247,27 +267,39 @@ module ScriptPreprocessClosure = let tcConfigB = tcConfig.CloneToBuilder() let mutable nowarns = [] - let getWarningNumber = fun () (m, s) -> nowarns <- (s, m) :: nowarns - let addReferenceDirective = fun () (m, s, directive) -> tcConfigB.AddReferenceDirective(dependencyProvider, m, s, directive) - let addLoadedSource = fun () (m, s) -> tcConfigB.AddLoadedSource(m, s, pathOfMetaCommandSource) + let getWarningNumber () (m, s) = nowarns <- (s, m) :: nowarns + + let addReferenceDirective () (m, s, directive) = + tcConfigB.AddReferenceDirective(dependencyProvider, m, s, directive) + + let addLoadedSource () (m, s) = + tcConfigB.AddLoadedSource(m, s, pathOfMetaCommandSource) + try - ProcessMetaCommandsFromInput (getWarningNumber, addReferenceDirective, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) + ProcessMetaCommandsFromInput + (getWarningNumber, addReferenceDirective, addLoadedSource) + (tcConfigB, inp, pathOfMetaCommandSource, ()) with ReportedError _ -> // Recover by using whatever did end up in the tcConfig () try - TcConfig.Create(tcConfigB, validate=false), nowarns + TcConfig.Create(tcConfigB, validate = false), nowarns with ReportedError _ -> // Recover by using a default TcConfig. let tcConfigB = tcConfig.CloneToBuilder() - TcConfig.Create(tcConfigB, validate=false), nowarns + TcConfig.Create(tcConfigB, validate = false), nowarns + + let getDirective d = + match d with + | Directive.Resolution -> "r" + | Directive.Include -> "i" let FindClosureFiles ( mainFile, closureSources, - origTcConfig:TcConfig, + origTcConfig: TcConfig, codeContext, lexResourceManager: Lexhelp.LexResourceManager, dependencyProvider: DependencyProvider @@ -281,165 +313,273 @@ module ScriptPreprocessClosure = // Resolve the packages let rec resolveDependencyManagerSources scriptName = - if not (loadScripts.Contains scriptName) then - [ for kv in tcConfig.packageManagerLines do - let packageManagerKey, packageManagerLines = kv.Key, kv.Value - match packageManagerLines with - | [] -> () - | { Directive=_; LineStatus=_; Line=_; Range=m } :: _ -> - let reportError = - ResolvingErrorReport (fun errorType err msg -> - let error = err, msg - match errorType with - | ErrorReportType.Warning -> warning(Error(error, m)) - | ErrorReportType.Error -> errorR(Error(error, m))) - - match origTcConfig.packageManagerLines |> Map.tryFind packageManagerKey with - | Some oldDependencyManagerLines when oldDependencyManagerLines = packageManagerLines -> () - | _ -> - let outputDir = tcConfig.outputDir |> Option.defaultValue "" - match dependencyProvider.TryFindDependencyManagerByKey(tcConfig.compilerToolPaths, outputDir, reportError, packageManagerKey) with - | Null -> - errorR(Error(dependencyProvider.CreatePackageManagerUnknownError(tcConfig.compilerToolPaths, outputDir, packageManagerKey, reportError), m)) - - | NonNull dependencyManager -> - let directive d = - match d with - | Directive.Resolution -> "r" - | Directive.Include -> "i" - - let packageManagerTextLines = packageManagerLines |> List.map(fun l -> directive l.Directive, l.Line) - let tfm, rid = tcConfig.FxResolver.GetTfmAndRid() - let result = dependencyProvider.Resolve(dependencyManager, ".fsx", packageManagerTextLines, reportError, tfm, rid, tcConfig.implicitIncludeDir, mainFile, scriptName) - if result.Success then - // Resolution produced no errors - //Write outputs in F# Interactive and compiler - if codeContext <> CodeContext.Editing then - for line in result.StdOut do Console.Out.WriteLine(line) - for line in result.StdError do Console.Error.WriteLine(line) - - packageReferences[m] <- [ for script in result.SourceFiles do yield! FileSystem.OpenFileForReadShim(script).ReadLines() ] - if not (Seq.isEmpty result.Roots) then - let tcConfigB = tcConfig.CloneToBuilder() - for folder in result.Roots do - tcConfigB.AddIncludePath(m, folder, "") - tcConfigB.packageManagerLines <- PackageManagerLine.SetLinesAsProcessed packageManagerKey tcConfigB.packageManagerLines - tcConfig <- TcConfig.Create(tcConfigB, validate=false) - - if not (Seq.isEmpty result.Resolutions) then - let tcConfigB = tcConfig.CloneToBuilder() - for resolution in result.Resolutions do - tcConfigB.AddReferencedAssemblyByPath(m, resolution) - tcConfig <- TcConfig.Create(tcConfigB, validate = false) - - for script in result.SourceFiles do - use stream = FileSystem.OpenFileForReadShim(script) - let scriptText = stream.ReadAllText() - loadScripts.Add script |> ignore - let iSourceText = SourceText.ofString scriptText - yield! loop (ClosureSource(script, m, iSourceText, true)) - - else - // Send outputs via diagnostics - if (result.StdOut.Length > 0 || result.StdError.Length > 0) then - for line in Array.append result.StdOut result.StdError do - errorR(Error(FSComp.SR.packageManagerError(line), m)) - // Resolution produced errors update packagerManagerLines entries to note these failure - // failed resolutions will no longer be considered - let tcConfigB = tcConfig.CloneToBuilder() - tcConfigB.packageManagerLines <- PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines - tcConfig <- TcConfig.Create(tcConfigB, validate=false)] - else [] - - and loop (ClosureSource(fileName, m, sourceText, parseRequired)) = - [ if not (observedSources.HaveSeen(fileName)) then + [ + if not (loadScripts.Contains scriptName) then + for kv in tcConfig.packageManagerLines do + let packageManagerKey, packageManagerLines = kv.Key, kv.Value + + match packageManagerLines with + | [] -> () + | packageManagerLine :: _ -> + let m = packageManagerLine.Range + yield! processPackageManagerLines m packageManagerLines scriptName packageManagerKey + ] + + and reportError m = + ResolvingErrorReport(fun errorType err msg -> + let error = err, msg + + match errorType with + | ErrorReportType.Warning -> warning (Error(error, m)) + | ErrorReportType.Error -> errorR (Error(error, m))) + + and processPackageManagerLines m packageManagerLines scriptName packageManagerKey = + [ + + match origTcConfig.packageManagerLines |> Map.tryFind packageManagerKey with + | Some oldDependencyManagerLines when oldDependencyManagerLines = packageManagerLines -> () + | _ -> + let outputDir = tcConfig.outputDir |> Option.defaultValue "" + + let managerOpt = + dependencyProvider.TryFindDependencyManagerByKey( + tcConfig.compilerToolPaths, + outputDir, + reportError m, + packageManagerKey + ) + + match managerOpt with + | Null -> + let err = + dependencyProvider.CreatePackageManagerUnknownError( + tcConfig.compilerToolPaths, + outputDir, + packageManagerKey, + reportError m + ) + + errorR (Error(err, m)) + + | NonNull dependencyManager -> + yield! resolvePackageManagerLines m packageManagerLines scriptName packageManagerKey dependencyManager + ] + + and resolvePackageManagerLines m packageManagerLines scriptName packageManagerKey dependencyManager = + [ + let packageManagerTextLines = + packageManagerLines |> List.map (fun l -> getDirective l.Directive, l.Line) + + let tfm, rid = tcConfig.FxResolver.GetTfmAndRid() + + let result = + dependencyProvider.Resolve( + dependencyManager, + ".fsx", + packageManagerTextLines, + reportError m, + tfm, + rid, + tcConfig.implicitIncludeDir, + mainFile, + scriptName + ) + + if result.Success then + // Resolution produced no errors + //Write outputs in F# Interactive and compiler + if codeContext <> CodeContext.Editing then + for line in result.StdOut do + Console.Out.WriteLine(line) + + for line in result.StdError do + Console.Error.WriteLine(line) + + packageReferences[m] <- + [ + for script in result.SourceFiles do + yield! FileSystem.OpenFileForReadShim(script).ReadLines() + ] + + if not (Seq.isEmpty result.Roots) then + let tcConfigB = tcConfig.CloneToBuilder() + + for folder in result.Roots do + tcConfigB.AddIncludePath(m, folder, "") + + tcConfigB.packageManagerLines <- + PackageManagerLine.SetLinesAsProcessed packageManagerKey tcConfigB.packageManagerLines + + tcConfig <- TcConfig.Create(tcConfigB, validate = false) + + if not (Seq.isEmpty result.Resolutions) then + let tcConfigB = tcConfig.CloneToBuilder() + + for resolution in result.Resolutions do + tcConfigB.AddReferencedAssemblyByPath(m, resolution) + + tcConfig <- TcConfig.Create(tcConfigB, validate = false) + + for script in result.SourceFiles do + use stream = FileSystem.OpenFileForReadShim(script) + let scriptText = stream.ReadAllText() + loadScripts.Add script |> ignore + let iSourceText = SourceText.ofString scriptText + yield! processClosureSource (ClosureSource(script, m, iSourceText, true)) + + else + // Send outputs via diagnostics + if (result.StdOut.Length > 0 || result.StdError.Length > 0) then + for line in Array.append result.StdOut result.StdError do + errorR (Error(FSComp.SR.packageManagerError (line), m)) + // Resolution produced errors update packagerManagerLines entries to note these failure + // failed resolutions will no longer be considered + let tcConfigB = tcConfig.CloneToBuilder() + + tcConfigB.packageManagerLines <- + PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines + + tcConfig <- TcConfig.Create(tcConfigB, validate = false) + ] + + and processClosureSource (ClosureSource (fileName, m, sourceText, parseRequired)) = + [ + if not (observedSources.HaveSeen(fileName)) then observedSources.SetSeen(fileName) //printfn "visiting %s" fileName if IsScript fileName || parseRequired then let parseResult, parseDiagnostics = let diagnosticsLogger = CapturingDiagnosticsLogger("FindClosureParse") - use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) - let result = ParseScriptClosureInput (fileName, sourceText, tcConfig, codeContext, lexResourceManager, diagnosticsLogger) + use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) + + let result = + ParseScriptClosureInput(fileName, sourceText, tcConfig, codeContext, lexResourceManager, diagnosticsLogger) + result, diagnosticsLogger.Diagnostics let diagnosticsLogger = CapturingDiagnosticsLogger("FindClosureMetaCommands") - use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) + use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) let pathOfMetaCommandSource = Path.GetDirectoryName fileName let preSources = tcConfig.GetAvailableLoadedSources() - let tcConfigResult, noWarns = ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn (tcConfig, parseResult, pathOfMetaCommandSource, dependencyProvider) + let tcConfigResult, noWarns = + ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn( + tcConfig, + parseResult, + pathOfMetaCommandSource, + dependencyProvider + ) + tcConfig <- tcConfigResult // We accumulate the tcConfig in order to collect assembly references yield! resolveDependencyManagerSources fileName let postSources = tcConfig.GetAvailableLoadedSources() - let sources = if preSources.Length < postSources.Length then postSources[preSources.Length..] else [] + + let sources = + if preSources.Length < postSources.Length then + postSources[preSources.Length ..] + else + [] yield! resolveDependencyManagerSources fileName + for m, subFile in sources do if IsScript subFile then for subSource in ClosureSourceOfFilename(subFile, m, tcConfigResult.inputCodePage, false) do - yield! loop subSource + yield! processClosureSource subSource else - yield ClosureFile(subFile, m, None, [], [], []) - yield ClosureFile(fileName, m, Some parseResult, parseDiagnostics, diagnosticsLogger.Diagnostics, noWarns) + ClosureFile(subFile, m, None, [], [], []) + + ClosureFile(fileName, m, Some parseResult, parseDiagnostics, diagnosticsLogger.Diagnostics, noWarns) else // Don't traverse into .fs leafs. printfn "yielding non-script source %s" fileName - yield ClosureFile(fileName, m, None, [], [], []) ] + ClosureFile(fileName, m, None, [], [], []) + ] + + let sources = closureSources |> List.collect processClosureSource + + let packageReferences = + packageReferences |> Seq.map (fun kvp -> kvp.Key, kvp.Value) |> Seq.toArray - let sources = closureSources |> List.collect loop - let packageReferences = packageReferences |> Seq.map (fun kvp -> kvp.Key, kvp.Value) |> Seq.toArray sources, tcConfig, packageReferences + /// Mark the last file as isLastCompiland. + let MarkLastCompiland (tcConfig: TcConfig, lastClosureFile) = + let (ClosureFile (fileName, m, lastParsedInput, parseDiagnostics, metaDiagnostics, nowarns)) = + lastClosureFile + + match lastParsedInput with + | Some (ParsedInput.ImplFile lastParsedImplFile) -> + + let (ParsedImplFileInput (name, isScript, qualNameOfFile, scopedPragmas, hashDirectives, implFileFlags, _, trivia)) = + lastParsedImplFile + + let isLastCompiland = (true, tcConfig.target.IsExe) + + let lastParsedImplFileR = + ParsedImplFileInput(name, isScript, qualNameOfFile, scopedPragmas, hashDirectives, implFileFlags, isLastCompiland, trivia) + + let lastClosureFileR = + ClosureFile(fileName, m, Some(ParsedInput.ImplFile lastParsedImplFileR), parseDiagnostics, metaDiagnostics, nowarns) + + lastClosureFileR + | _ -> lastClosureFile + /// Reduce the full directive closure into LoadClosure - let GetLoadClosure(rootFilename, closureFiles, tcConfig: TcConfig, codeContext, packageReferences, earlierDiagnostics) = + let GetLoadClosure (rootFilename, closureFiles, tcConfig: TcConfig, codeContext, packageReferences, earlierDiagnostics) = // Mark the last file as isLastCompiland. let closureFiles = - if isNil closureFiles then - closureFiles - else - match List.frontAndBack closureFiles with - | rest, ClosureFile - (fileName, m, - Some(ParsedInput.ImplFile (ParsedImplFileInput (name, isScript, qualNameOfFile, scopedPragmas, hashDirectives, implFileFlags, _, trivia))), - parseDiagnostics, metaDiagnostics, nowarns) -> - - let isLastCompiland = (true, tcConfig.target.IsExe) - rest @ [ClosureFile - (fileName, m, - Some(ParsedInput.ImplFile (ParsedImplFileInput (name, isScript, qualNameOfFile, scopedPragmas, hashDirectives, implFileFlags, isLastCompiland, trivia))), - parseDiagnostics, metaDiagnostics, nowarns)] - - | _ -> closureFiles + match List.tryFrontAndBack closureFiles with + | None -> closureFiles + | Some (rest, lastClosureFile) -> + let lastClosureFileR = MarkLastCompiland(tcConfig, lastClosureFile) + rest @ [ lastClosureFileR ] // Get all source files. - let sourceFiles = [ for ClosureFile(fileName, m, _, _, _, _) in closureFiles -> (fileName, m) ] + let sourceFiles = + [ for ClosureFile (fileName, m, _, _, _, _) in closureFiles -> (fileName, m) ] let sourceInputs = - [ for ClosureFile(fileName, _, input, parseDiagnostics, metaDiagnostics, _nowarns) in closureFiles -> - ({ FileName=fileName - SyntaxTree=input - ParseDiagnostics=parseDiagnostics - MetaCommandDiagnostics=metaDiagnostics } : LoadClosureInput) ] - - let globalNoWarns = closureFiles |> List.collect (fun (ClosureFile(_, _, _, _, _, noWarns)) -> noWarns) + [ + for closureFile in closureFiles -> + let (ClosureFile (fileName, _, input, parseDiagnostics, metaDiagnostics, _nowarns)) = + closureFile + + let closureInput: LoadClosureInput = + { + FileName = fileName + SyntaxTree = input + ParseDiagnostics = parseDiagnostics + MetaCommandDiagnostics = metaDiagnostics + } + + closureInput + ] + + let globalNoWarns = + closureFiles + |> List.collect (fun (ClosureFile (_, _, _, _, _, noWarns)) -> noWarns) // Resolve all references. let references, unresolvedReferences, resolutionDiagnostics = let diagnosticsLogger = CapturingDiagnosticsLogger("GetLoadClosure") - use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) - let references, unresolvedReferences = TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) + use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) + + let references, unresolvedReferences = + TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) + let references = references |> List.map (fun ar -> ar.resolvedPath, ar) references, unresolvedReferences, diagnosticsLogger.Diagnostics // Root errors and warnings - look at the last item in the closureFiles list let loadClosureRootDiagnostics, allRootDiagnostics = match List.rev closureFiles with - | ClosureFile(_, _, _, parseDiagnostics, metaDiagnostics, _) :: _ -> + | ClosureFile (_, _, _, parseDiagnostics, metaDiagnostics, _) :: _ -> (earlierDiagnostics @ metaDiagnostics @ resolutionDiagnostics), (parseDiagnostics @ earlierDiagnostics @ metaDiagnostics @ resolutionDiagnostics) | _ -> [], [] // When no file existed. @@ -448,8 +588,13 @@ module ScriptPreprocessClosure = match GetRangeOfDiagnostic exn with | Some m -> // Return true if the error was *not* from a #load-ed file. - let isArgParameterWhileNotEditing = (codeContext <> CodeContext.Editing) && (equals m range0 || equals m rangeStartup || equals m rangeCmdArgs) - let isThisFileName = (0 = String.Compare(rootFilename, m.FileName, StringComparison.OrdinalIgnoreCase)) + let isArgParameterWhileNotEditing = + (codeContext <> CodeContext.Editing) + && (equals m range0 || equals m rangeStartup || equals m rangeCmdArgs) + + let isThisFileName = + (0 = String.Compare(rootFilename, m.FileName, StringComparison.OrdinalIgnoreCase)) + isArgParameterWhileNotEditing || isThisFileName | None -> true @@ -457,18 +602,20 @@ module ScriptPreprocessClosure = let allRootDiagnostics = allRootDiagnostics |> List.filter (fst >> isRootRange) let result: LoadClosure = - { SourceFiles = List.groupBy fst sourceFiles |> List.map (map2Of2 (List.map snd)) - References = List.groupBy fst references |> List.map (map2Of2 (List.map snd)) - PackageReferences = packageReferences - UseDesktopFramework = (tcConfig.primaryAssembly = PrimaryAssembly.Mscorlib) - SdkDirOverride = tcConfig.sdkDirOverride - UnresolvedReferences = unresolvedReferences - Inputs = sourceInputs - NoWarns = List.groupBy fst globalNoWarns |> List.map (map2Of2 (List.map snd)) - OriginalLoadReferences = tcConfig.loadedSources - ResolutionDiagnostics = resolutionDiagnostics - AllRootFileDiagnostics = allRootDiagnostics - LoadClosureRootFileDiagnostics = loadClosureRootDiagnostics } + { + SourceFiles = List.groupBy fst sourceFiles |> List.map (map2Of2 (List.map snd)) + References = List.groupBy fst references |> List.map (map2Of2 (List.map snd)) + PackageReferences = packageReferences + UseDesktopFramework = (tcConfig.primaryAssembly = PrimaryAssembly.Mscorlib) + SdkDirOverride = tcConfig.sdkDirOverride + UnresolvedReferences = unresolvedReferences + Inputs = sourceInputs + NoWarns = List.groupBy fst globalNoWarns |> List.map (map2Of2 (List.map snd)) + OriginalLoadReferences = tcConfig.loadedSources + ResolutionDiagnostics = resolutionDiagnostics + AllRootFileDiagnostics = allRootDiagnostics + LoadClosureRootFileDiagnostics = loadClosureRootDiagnostics + } result @@ -498,42 +645,81 @@ module ScriptPreprocessClosure = // first, then #I and other directives are processed. let references0, assumeDotNetFramework, scriptDefaultReferencesDiagnostics = let tcConfig, scriptDefaultReferencesDiagnostics = - CreateScriptTextTcConfig(legacyReferenceResolver, defaultFSharpBinariesDir, - fileName, codeContext, useSimpleResolution, - useFsiAuxLib, None, applyCommandLineArgs, assumeDotNetFramework, - useSdkRefs, sdkDirOverride, tryGetMetadataSnapshot, reduceMemoryUsage) + CreateScriptTextTcConfig( + legacyReferenceResolver, + defaultFSharpBinariesDir, + fileName, + codeContext, + useSimpleResolution, + useFsiAuxLib, + None, + applyCommandLineArgs, + assumeDotNetFramework, + useSdkRefs, + sdkDirOverride, + tryGetMetadataSnapshot, + reduceMemoryUsage + ) + + let resolutions0, _unresolvedReferences = + TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) + + let references0 = + resolutions0 + |> List.map (fun r -> r.originalReference.Range, r.resolvedPath) + |> Seq.distinct + |> List.ofSeq - let resolutions0, _unresolvedReferences = TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) - let references0 = resolutions0 |> List.map (fun r->r.originalReference.Range, r.resolvedPath) |> Seq.distinct |> List.ofSeq references0, tcConfig.assumeDotNetFramework, scriptDefaultReferencesDiagnostics let tcConfig, scriptDefaultReferencesDiagnostics = - CreateScriptTextTcConfig(legacyReferenceResolver, defaultFSharpBinariesDir, fileName, - codeContext, useSimpleResolution, useFsiAuxLib, Some (references0, scriptDefaultReferencesDiagnostics), - applyCommandLineArgs, assumeDotNetFramework, useSdkRefs, sdkDirOverride, - tryGetMetadataSnapshot, reduceMemoryUsage) + CreateScriptTextTcConfig( + legacyReferenceResolver, + defaultFSharpBinariesDir, + fileName, + codeContext, + useSimpleResolution, + useFsiAuxLib, + Some(references0, scriptDefaultReferencesDiagnostics), + applyCommandLineArgs, + assumeDotNetFramework, + useSdkRefs, + sdkDirOverride, + tryGetMetadataSnapshot, + reduceMemoryUsage + ) + + let closureSources = [ ClosureSource(fileName, range0, sourceText, true) ] + + let closureFiles, tcConfig, packageReferences = + FindClosureFiles(fileName, closureSources, tcConfig, codeContext, lexResourceManager, dependencyProvider) - let closureSources = [ClosureSource(fileName, range0, sourceText, true)] - let closureFiles, tcConfig, packageReferences = FindClosureFiles(fileName, closureSources, tcConfig, codeContext, lexResourceManager, dependencyProvider) GetLoadClosure(fileName, closureFiles, tcConfig, codeContext, packageReferences, scriptDefaultReferencesDiagnostics) /// Given source file fileName, find the full load closure /// Used from fsi.fs and fsc.fs, for #load and command line let GetFullClosureOfScriptFiles ( - tcConfig:TcConfig, - files:(string*range) list, + tcConfig: TcConfig, + files: (string * range) list, codeContext, lexResourceManager: Lexhelp.LexResourceManager, dependencyProvider ) = let mainFile, _mainFileRange = List.last files - let closureSources = files |> List.collect (fun (fileName, m) -> ClosureSourceOfFilename(fileName, m,tcConfig.inputCodePage,true)) - let closureFiles, tcConfig, packageReferences = FindClosureFiles(mainFile, closureSources, tcConfig, codeContext, lexResourceManager, dependencyProvider) + + let closureSources = + files + |> List.collect (fun (fileName, m) -> ClosureSourceOfFilename(fileName, m, tcConfig.inputCodePage, true)) + + let closureFiles, tcConfig, packageReferences = + FindClosureFiles(mainFile, closureSources, tcConfig, codeContext, lexResourceManager, dependencyProvider) + GetLoadClosure(mainFile, closureFiles, tcConfig, codeContext, packageReferences, []) type LoadClosure with + /// Analyze a script text and find the closure of its references. /// Used from FCS, when editing a script file. /// @@ -559,20 +745,34 @@ type LoadClosure with ) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - ScriptPreprocessClosure.GetFullClosureOfScriptText - (legacyReferenceResolver, defaultFSharpBinariesDir, fileName, sourceText, - implicitDefines, useSimpleResolution, useFsiAuxLib, useSdkRefs, sdkDir, lexResourceManager, - applyCompilerOptions, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage, dependencyProvider) + + ScriptPreprocessClosure.GetFullClosureOfScriptText( + legacyReferenceResolver, + defaultFSharpBinariesDir, + fileName, + sourceText, + implicitDefines, + useSimpleResolution, + useFsiAuxLib, + useSdkRefs, + sdkDir, + lexResourceManager, + applyCompilerOptions, + assumeDotNetFramework, + tryGetMetadataSnapshot, + reduceMemoryUsage, + dependencyProvider + ) /// Analyze a set of script files and find the closure of their references. static member ComputeClosureOfScriptFiles ( tcConfig: TcConfig, - files:(string*range) list, + files: (string * range) list, implicitDefines, lexResourceManager: Lexhelp.LexResourceManager, dependencyProvider ) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - ScriptPreprocessClosure.GetFullClosureOfScriptFiles (tcConfig, files, implicitDefines, lexResourceManager, dependencyProvider) + ScriptPreprocessClosure.GetFullClosureOfScriptFiles(tcConfig, files, implicitDefines, lexResourceManager, dependencyProvider) diff --git a/src/Compiler/Driver/StaticLinking.fs b/src/Compiler/Driver/StaticLinking.fs index 94d3c7f3f33..6c23eb9b024 100644 --- a/src/Compiler/Driver/StaticLinking.fs +++ b/src/Compiler/Driver/StaticLinking.fs @@ -25,7 +25,7 @@ open FSharp.Compiler.TypeProviders #endif // Handles TypeForwarding for the generated IL model -type TypeForwarding (tcImports: TcImports) = +type TypeForwarding(tcImports: TcImports) = // Make a dictionary of ccus passed to the compiler will be looked up by qualified assembly name let ccuThunksQualifiedName = @@ -40,18 +40,20 @@ type TypeForwarding (tcImports: TcImports) = if String.IsNullOrEmpty(ccuThunk.AssemblyName) then None else - Some (ccuThunk.AssemblyName, ccuThunk)) + Some(ccuThunk.AssemblyName, ccuThunk)) |> dict - let followTypeForwardForILTypeRef (tref:ILTypeRef) = + let followTypeForwardForILTypeRef (tref: ILTypeRef) = let typename = - let parts = tref.FullName.Split([|'.'|]) + let parts = tref.FullName.Split([| '.' |]) + match parts.Length with | 0 -> None - | 1 -> Some (Array.empty, parts[0]) - | n -> Some (parts[0..n-2], parts[n-1]) + | 1 -> Some(Array.empty, parts[0]) + | n -> Some(parts[0 .. n - 2], parts[n - 1]) + + let scoref = tref.Scope - let scoref = tref.Scope match scoref with | ILScopeRef.Assembly scope -> match ccuThunksQualifiedName.TryGetValue(scope.QualifiedName) with @@ -59,10 +61,12 @@ type TypeForwarding (tcImports: TcImports) = match typename with | Some (parts, name) -> let forwarded = ccu.TryForward(parts, name) + let result = match forwarded with | Some fwd -> fwd.CompilationPath.ILScopeRef | None -> scoref + result | None -> scoref | false, _ -> @@ -72,10 +76,12 @@ type TypeForwarding (tcImports: TcImports) = match typename with | Some (parts, name) -> let forwarded = ccu.TryForward(parts, name) + let result = match forwarded with | Some fwd -> fwd.CompilationPath.ILScopeRef | None -> scoref + result | None -> scoref | false, _ -> scoref @@ -84,55 +90,83 @@ type TypeForwarding (tcImports: TcImports) = let typeForwardILTypeRef (tref: ILTypeRef) = let scoref1 = tref.Scope let scoref2 = followTypeForwardForILTypeRef tref - if scoref1 === scoref2 then tref - else ILTypeRef.Create (scoref2, tref.Enclosing, tref.Name) + + if scoref1 === scoref2 then + tref + else + ILTypeRef.Create(scoref2, tref.Enclosing, tref.Name) member _.TypeForwardILTypeRef tref = typeForwardILTypeRef tref let debugStaticLinking = condition "FSHARP_DEBUG_STATIC_LINKING" -let StaticLinkILModules (tcConfig:TcConfig, ilGlobals, tcImports, ilxMainModule, dependentILModules: (CcuThunk option * ILModuleDef) list) = +let StaticLinkILModules + ( + tcConfig: TcConfig, + ilGlobals, + tcImports, + ilxMainModule, + dependentILModules: (CcuThunk option * ILModuleDef) list + ) = if isNil dependentILModules then ilxMainModule, id else let typeForwarding = TypeForwarding(tcImports) // Check no dependent assemblies use quotations - let dependentCcuUsingQuotations = dependentILModules |> List.tryPick (function Some ccu, _ when ccu.UsesFSharp20PlusQuotations -> Some ccu | _ -> None) + let dependentCcuUsingQuotations = + dependentILModules + |> List.tryPick (function + | Some ccu, _ when ccu.UsesFSharp20PlusQuotations -> Some ccu + | _ -> None) + match dependentCcuUsingQuotations with - | Some ccu -> error(Error(FSComp.SR.fscQuotationLiteralsStaticLinking(ccu.AssemblyName), rangeStartup)) + | Some ccu -> error (Error(FSComp.SR.fscQuotationLiteralsStaticLinking (ccu.AssemblyName), rangeStartup)) | None -> () // Check we're not static linking a .EXE - if dependentILModules |> List.exists (fun (_, x) -> not x.IsDLL) then - error(Error(FSComp.SR.fscStaticLinkingNoEXE(), rangeStartup)) + if dependentILModules |> List.exists (fun (_, x) -> not x.IsDLL) then + error (Error(FSComp.SR.fscStaticLinkingNoEXE (), rangeStartup)) // Check we're not static linking something that is not pure IL - if dependentILModules |> List.exists (fun (_, x) -> not x.IsILOnly) then - error(Error(FSComp.SR.fscStaticLinkingNoMixedDLL(), rangeStartup)) + if dependentILModules |> List.exists (fun (_, x) -> not x.IsILOnly) then + error (Error(FSComp.SR.fscStaticLinkingNoMixedDLL (), rangeStartup)) // The set of short names for the all dependent assemblies let assems = - set [ for _, m in dependentILModules do - match m.Manifest with - | Some m -> yield m.Name - | _ -> () ] + set + [ + for _, m in dependentILModules do + match m.Manifest with + | Some m -> m.Name + | _ -> () + ] // A rewriter which rewrites scope references to things in dependent assemblies to be local references let rewriteExternalRefsToLocalRefs x = - if assems.Contains (getNameOfScopeRef x) then ILScopeRef.Local else x + if assems.Contains(getNameOfScopeRef x) then + ILScopeRef.Local + else + x let savedManifestAttrs = - [ for _, depILModule in dependentILModules do - match depILModule.Manifest with - | Some m -> - for ca in m.CustomAttrs.AsArray() do - if ca.Method.MethodRef.DeclaringTypeRef.FullName = typeof.FullName then - yield ca - | _ -> () ] + [ + for _, depILModule in dependentILModules do + match depILModule.Manifest with + | Some m -> + for ca in m.CustomAttrs.AsArray() do + if ca.Method.MethodRef.DeclaringTypeRef.FullName = typeof.FullName then + ca + | _ -> () + ] let savedResources = - let allResources = [ for ccu, m in dependentILModules do for r in m.Resources.AsList() do yield (ccu, r) ] + let allResources = + [ + for ccu, m in dependentILModules do + for r in m.Resources.AsList() do + (ccu, r) + ] // Don't save interface, optimization or resource definitions for provider-generated assemblies. // These are "fake". let isProvided (ccu: CcuThunk option) = @@ -146,21 +180,29 @@ let StaticLinkILModules (tcConfig:TcConfig, ilGlobals, tcImports, ilxMainModule, #endif // Save only the interface/optimization attributes of generated data - let intfDataResources, others = allResources |> List.partition (snd >> IsSignatureDataResource) + let intfDataResources, others = + allResources |> List.partition (snd >> IsSignatureDataResource) + let intfDataResources = - [ for ccu, r in intfDataResources do - if tcConfig.GenerateSignatureData && not (isProvided ccu) then - yield r ] + [ + for ccu, r in intfDataResources do + if tcConfig.GenerateSignatureData && not (isProvided ccu) then + r + ] + + let optDataResources, others = + others |> List.partition (snd >> IsOptimizationDataResource) - let optDataResources, others = others |> List.partition (snd >> IsOptimizationDataResource) let optDataResources = - [ for ccu, r in optDataResources do - if tcConfig.GenerateOptimizationData && not (isProvided ccu) then - yield r ] + [ + for ccu, r in optDataResources do + if tcConfig.GenerateOptimizationData && not (isProvided ccu) then + r + ] let otherResources = others |> List.map snd - let result = intfDataResources@optDataResources@otherResources + let result = intfDataResources @ optDataResources @ otherResources result let moduls = ilxMainModule :: (List.map snd dependentILModules) @@ -168,39 +210,62 @@ let StaticLinkILModules (tcConfig:TcConfig, ilGlobals, tcImports, ilxMainModule, let savedNativeResources = [ //yield! ilxMainModule.NativeResources for m in moduls do - yield! m.NativeResources ] + yield! m.NativeResources + ] let topTypeDefs, normalTypeDefs = moduls - |> List.map (fun m -> m.TypeDefs.AsList() |> List.partition (fun td -> isTypeNameForGlobalFunctions td.Name)) + |> List.map (fun m -> + m.TypeDefs.AsList() + |> List.partition (fun td -> isTypeNameForGlobalFunctions td.Name)) |> List.unzip let topTypeDef = let topTypeDefs = List.concat topTypeDefs - mkILTypeDefForGlobalFunctions ilGlobals + + mkILTypeDefForGlobalFunctions + ilGlobals (mkILMethods (topTypeDefs |> List.collect (fun td -> td.Methods.AsList())), - mkILFields (topTypeDefs |> List.collect (fun td -> td.Fields.AsList()))) + mkILFields (topTypeDefs |> List.collect (fun td -> td.Fields.AsList()))) + + let oldManifest = ilxMainModule.ManifestOfAssembly + + let newManifest = + { oldManifest with + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs (oldManifest.CustomAttrs.AsList() @ savedManifestAttrs)) + } let ilxMainModule = let main = { ilxMainModule with - Manifest = (let m = ilxMainModule.ManifestOfAssembly in Some {m with CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs (m.CustomAttrs.AsList() @ savedManifestAttrs)) }) - CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs [ for m in moduls do yield! m.CustomAttrs.AsArray() ]) + Manifest = Some newManifest + CustomAttrsStored = + storeILCustomAttrs ( + mkILCustomAttrs + [ + for m in moduls do + yield! m.CustomAttrs.AsArray() + ] + ) TypeDefs = mkILTypeDefs (topTypeDef :: List.concat normalTypeDefs) Resources = mkILResources (savedResources @ ilxMainModule.Resources.AsList()) - NativeResources = savedNativeResources } + NativeResources = savedNativeResources + } + Morphs.morphILTypeRefsInILModuleMemoized typeForwarding.TypeForwardILTypeRef main ilxMainModule, rewriteExternalRefsToLocalRefs [] type Node = - { name: string - data: ILModuleDef - ccu: CcuThunk option - refs: ILReferences - mutable edges: Node list - mutable visited: bool } + { + name: string + data: ILModuleDef + ccu: CcuThunk option + refs: ILReferences + mutable edges: Node list + mutable visited: bool + } // Find all IL modules that are to be statically linked given the static linking roots. let FindDependentILModulesForStaticLinking (ctok, tcConfig: TcConfig, tcImports: TcImports, ilGlobals: ILGlobals, ilxMainModule) = @@ -209,130 +274,217 @@ let FindDependentILModulesForStaticLinking (ctok, tcConfig: TcConfig, tcImports: else // Recursively find all referenced modules and add them to a module graph let depModuleTable = HashMultiMap(0, HashIdentity.Structural) + let dummyEntry nm = - { refs = emptyILRefs - name=nm - ccu=None - data=ilxMainModule // any old module - edges = [] - visited = true } - let assumedIndependentSet = set [ "mscorlib"; "System"; "System.Core"; "System.Xml"; "Microsoft.Build.Framework"; "Microsoft.Build.Utilities"; "netstandard" ] - - begin - let mutable remaining = (computeILRefs ilGlobals ilxMainModule).AssemblyReferences |> Array.toList - while not (isNil remaining) do - let ilAssemRef = List.head remaining - remaining <- List.tail remaining - if assumedIndependentSet.Contains ilAssemRef.Name || (ilAssemRef.PublicKey = Some ecmaPublicKey) then - depModuleTable[ilAssemRef.Name] <- dummyEntry ilAssemRef.Name - else - if not (depModuleTable.ContainsKey ilAssemRef.Name) then - match tcImports.TryFindDllInfo(ctok, rangeStartup, ilAssemRef.Name, lookupOnly=false) with - | Some dllInfo -> - let ccu = - match tcImports.FindCcuFromAssemblyRef (ctok, rangeStartup, ilAssemRef) with - | ResolvedCcu ccu -> Some ccu - | UnresolvedCcu(_ccuName) -> None - - let fileName = dllInfo.FileName - let modul = - let pdbDirPathOption = - // We open the pdb file if one exists parallel to the binary we - // are reading, so that --standalone will preserve debug information. - if tcConfig.openDebugInformationForLaterStaticLinking then - let pdbDir = (try FileSystem.GetDirectoryNameShim fileName with _ -> ".") - let pdbFile = (try FileSystemUtils.chopExtension fileName with _ -> fileName)+".pdb" - if FileSystem.FileExistsShim pdbFile then - Some pdbDir - else - None - else - None - - let opts : ILReaderOptions = - { metadataOnly = MetadataOnlyFlag.No // turn this off here as we need the actual IL code - reduceMemoryUsage = tcConfig.reduceMemoryUsage - pdbDirPath = pdbDirPathOption - tryGetMetadataSnapshot = (fun _ -> None) } - - let reader = OpenILModuleReader dllInfo.FileName opts - reader.ILModuleDef - - let refs = - if ilAssemRef.Name = GetFSharpCoreLibraryName() then - emptyILRefs - elif not modul.IsILOnly then - warning(Error(FSComp.SR.fscIgnoringMixedWhenLinking ilAssemRef.Name, rangeStartup)) - emptyILRefs + { + refs = emptyILRefs + name = nm + ccu = None + data = ilxMainModule // any old module + edges = [] + visited = true + } + + let assumedIndependentSet = + set + [ + "mscorlib" + "System" + "System.Core" + "System.Xml" + "Microsoft.Build.Framework" + "Microsoft.Build.Utilities" + "netstandard" + ] + + let mutable remaining = + (computeILRefs ilGlobals ilxMainModule).AssemblyReferences |> Array.toList + + while not (isNil remaining) do + let ilAssemRef = List.head remaining + remaining <- List.tail remaining + + if assumedIndependentSet.Contains ilAssemRef.Name + || (ilAssemRef.PublicKey = Some ecmaPublicKey) then + depModuleTable[ilAssemRef.Name] <- dummyEntry ilAssemRef.Name + else if not (depModuleTable.ContainsKey ilAssemRef.Name) then + match tcImports.TryFindDllInfo(ctok, rangeStartup, ilAssemRef.Name, lookupOnly = false) with + | Some dllInfo -> + let ccu = + match tcImports.FindCcuFromAssemblyRef(ctok, rangeStartup, ilAssemRef) with + | ResolvedCcu ccu -> Some ccu + | UnresolvedCcu (_ccuName) -> None + + let fileName = dllInfo.FileName + + let modul = + let pdbDirPathOption = + // We open the pdb file if one exists parallel to the binary we + // are reading, so that --standalone will preserve debug information. + if tcConfig.openDebugInformationForLaterStaticLinking then + let pdbDir = + (try + FileSystem.GetDirectoryNameShim fileName + with _ -> + ".") + + let pdbFile = + (try + FileSystemUtils.chopExtension fileName + with _ -> + fileName) + + ".pdb" + + if FileSystem.FileExistsShim pdbFile then + Some pdbDir else - { AssemblyReferences = dllInfo.ILAssemblyRefs |> List.toArray - ModuleReferences = [| |] - TypeReferences = [| |] - MethodReferences = [| |] - FieldReferences = [||] } - - depModuleTable[ilAssemRef.Name] <- - { refs=refs - name=ilAssemRef.Name - ccu=ccu - data=modul - edges = [] - visited = false } - - // Push the new work items - remaining <- Array.toList refs.AssemblyReferences @ remaining - - | None -> - warning(Error(FSComp.SR.fscAssumeStaticLinkContainsNoDependencies(ilAssemRef.Name), rangeStartup)) - depModuleTable[ilAssemRef.Name] <- dummyEntry ilAssemRef.Name - done - end + None + else + None + + let opts: ILReaderOptions = + { + metadataOnly = MetadataOnlyFlag.No // turn this off here as we need the actual IL code + reduceMemoryUsage = tcConfig.reduceMemoryUsage + pdbDirPath = pdbDirPathOption + tryGetMetadataSnapshot = (fun _ -> None) + } + + let reader = OpenILModuleReader dllInfo.FileName opts + reader.ILModuleDef + + let refs = + if ilAssemRef.Name = GetFSharpCoreLibraryName() then + emptyILRefs + elif not modul.IsILOnly then + warning (Error(FSComp.SR.fscIgnoringMixedWhenLinking ilAssemRef.Name, rangeStartup)) + emptyILRefs + else + { + AssemblyReferences = dllInfo.ILAssemblyRefs |> List.toArray + ModuleReferences = [||] + TypeReferences = [||] + MethodReferences = [||] + FieldReferences = [||] + } + + depModuleTable[ilAssemRef.Name] <- + { + refs = refs + name = ilAssemRef.Name + ccu = ccu + data = modul + edges = [] + visited = false + } + + // Push the new work items + remaining <- Array.toList refs.AssemblyReferences @ remaining + + | None -> + warning (Error(FSComp.SR.fscAssumeStaticLinkContainsNoDependencies (ilAssemRef.Name), rangeStartup)) + depModuleTable[ilAssemRef.Name] <- dummyEntry ilAssemRef.Name ReportTime tcConfig "Find dependencies" // Add edges from modules to the modules that depend on them - for KeyValue(_, n) in depModuleTable do + for KeyValue (_, n) in depModuleTable do for aref in n.refs.AssemblyReferences do let n2 = depModuleTable[aref.Name] n2.edges <- n :: n2.edges // Find everything that depends on FSharp.Core let roots = - [ if tcConfig.standalone && depModuleTable.ContainsKey (GetFSharpCoreLibraryName()) then - yield depModuleTable[GetFSharpCoreLibraryName()] - for n in tcConfig.extraStaticLinkRoots do - match depModuleTable.TryFind n with - | Some x -> yield x - | None -> error(Error(FSComp.SR.fscAssemblyNotFoundInDependencySet n, rangeStartup)) + [ + if tcConfig.standalone && depModuleTable.ContainsKey(GetFSharpCoreLibraryName()) then + depModuleTable[GetFSharpCoreLibraryName()] + for n in tcConfig.extraStaticLinkRoots do + match depModuleTable.TryFind n with + | Some x -> x + | None -> error (Error(FSComp.SR.fscAssemblyNotFoundInDependencySet n, rangeStartup)) ] let mutable remaining = roots - [ while not (isNil remaining) do - let n = List.head remaining - remaining <- List.tail remaining - if not n.visited then - n.visited <- true - remaining <- n.edges @ remaining - yield (n.ccu, n.data) ] + + [ + while not (isNil remaining) do + let n = List.head remaining + remaining <- List.tail remaining + + if not n.visited then + n.visited <- true + remaining <- n.edges @ remaining + (n.ccu, n.data) + ] // Add all provider-generated assemblies into the static linking set let FindProviderGeneratedILModules (ctok, tcImports: TcImports, providerGeneratedAssemblies: (ImportedBinary * _) list) = - [ for importedBinary, provAssemStaticLinkInfo in providerGeneratedAssemblies do - let ilAssemRef = - match importedBinary.ILScopeRef with - | ILScopeRef.Assembly aref -> aref - | _ -> failwith "Invalid ILScopeRef, expected ILScopeRef.Assembly" - if debugStaticLinking then printfn "adding provider-generated assembly '%s' into static linking set" ilAssemRef.Name - match tcImports.TryFindDllInfo(ctok, rangeStartup, ilAssemRef.Name, lookupOnly=false) with - | Some dllInfo -> - let ccu = - match tcImports.FindCcuFromAssemblyRef (ctok, rangeStartup, ilAssemRef) with - | ResolvedCcu ccu -> Some ccu - | UnresolvedCcu(_ccuName) -> None - - let modul = dllInfo.RawMetadata.TryGetILModuleDef().Value - yield (ccu, dllInfo.ILScopeRef, modul), (ilAssemRef.Name, provAssemStaticLinkInfo) - | None -> () ] + [ + for importedBinary, provAssemStaticLinkInfo in providerGeneratedAssemblies do + let ilAssemRef = + match importedBinary.ILScopeRef with + | ILScopeRef.Assembly aref -> aref + | _ -> failwith "Invalid ILScopeRef, expected ILScopeRef.Assembly" + + if debugStaticLinking then + printfn "adding provider-generated assembly '%s' into static linking set" ilAssemRef.Name + + match tcImports.TryFindDllInfo(ctok, rangeStartup, ilAssemRef.Name, lookupOnly = false) with + | Some dllInfo -> + let ccu = + match tcImports.FindCcuFromAssemblyRef(ctok, rangeStartup, ilAssemRef) with + | ResolvedCcu ccu -> Some ccu + | UnresolvedCcu (_ccuName) -> None + + let modul = dllInfo.RawMetadata.TryGetILModuleDef().Value + (ccu, dllInfo.ILScopeRef, modul), (ilAssemRef.Name, provAssemStaticLinkInfo) + | None -> () + ] + +/// Split the list into left, middle and right parts at the first element satisfying 'p'. If no element matches return +/// 'None' for the middle part. +let trySplitFind p xs = + let rec loop xs acc = + match xs with + | [] -> List.rev acc, None, [] + | h :: t -> if p h then List.rev acc, Some h, t else loop t (h :: acc) + + loop xs [] + +/// Implant the (nested) type definition 'td' at path 'enc' in 'tdefs'. +let rec implantTypeDef ilGlobals isNested (tdefs: ILTypeDefs) (enc: string list) (td: ILTypeDef) = + match enc with + | [] -> addILTypeDef td tdefs + | h :: t -> + let tdefs = tdefs.AsList() + + let ltdefs, htd, rtdefs = + match tdefs |> trySplitFind (fun td -> td.Name = h) with + | ltdefs, None, rtdefs -> + let access = + if isNested then + ILTypeDefAccess.Nested ILMemberAccess.Public + else + ILTypeDefAccess.Public + + let fresh = + mkILSimpleClass + ilGlobals + (h, + access, + emptyILMethods, + emptyILFields, + emptyILTypeDefs, + emptyILProperties, + emptyILEvents, + emptyILCustomAttrs, + ILTypeInit.OnAny) + + (ltdefs, fresh, rtdefs) + | ltdefs, Some htd, rtdefs -> (ltdefs, htd, rtdefs) + + let htd = htd.With(nestedTypes = implantTypeDef ilGlobals true htd.NestedTypes t td) + mkILTypeDefs (ltdefs @ [ htd ] @ rtdefs) // Compute a static linker. This only captures tcImports (a large data structure) if // static linking is enabled. Normally this is not the case, which lets us collect tcImports @@ -343,181 +495,231 @@ let StaticLink (ctok, tcConfig: TcConfig, tcImports: TcImports, ilGlobals: ILGlo let providerGeneratedAssemblies = [ // Add all EST-generated assemblies into the static linking set - for KeyValue(_, importedBinary: ImportedBinary) in tcImports.DllTable do + for KeyValue (_, importedBinary: ImportedBinary) in tcImports.DllTable do if importedBinary.IsProviderGenerated then match importedBinary.ProviderGeneratedStaticLinkMap with | None -> () - | Some provAssemStaticLinkInfo -> yield (importedBinary, provAssemStaticLinkInfo) ] + | Some provAssemStaticLinkInfo -> (importedBinary, provAssemStaticLinkInfo) + ] #endif - if not tcConfig.standalone && tcConfig.extraStaticLinkRoots.IsEmpty + if not tcConfig.standalone + && tcConfig.extraStaticLinkRoots.IsEmpty #if !NO_TYPEPROVIDERS - && providerGeneratedAssemblies.IsEmpty + && providerGeneratedAssemblies.IsEmpty #endif - then + then id else - (fun ilxMainModule -> + (fun ilxMainModule -> match tcConfig.emitMetadataAssembly with | MetadataAssemblyGeneration.None -> () - | _ -> - error(Error(FSComp.SR.optsInvalidRefAssembly(), rangeCmdArgs)) + | _ -> error (Error(FSComp.SR.optsInvalidRefAssembly (), rangeCmdArgs)) ReportTime tcConfig "Find assembly references" - let dependentILModules = FindDependentILModulesForStaticLinking (ctok, tcConfig, tcImports, ilGlobals, ilxMainModule) + let dependentILModules = + FindDependentILModulesForStaticLinking(ctok, tcConfig, tcImports, ilGlobals, ilxMainModule) ReportTime tcConfig "Static link" #if !NO_TYPEPROVIDERS - Morphs.enableMorphCustomAttributeData() - let providerGeneratedILModules = FindProviderGeneratedILModules (ctok, tcImports, providerGeneratedAssemblies) + Morphs.enableMorphCustomAttributeData () + + let providerGeneratedILModules = + FindProviderGeneratedILModules(ctok, tcImports, providerGeneratedAssemblies) // Transform the ILTypeRefs references in the IL of all provider-generated assemblies so that the references // are now local. let providerGeneratedILModules = - providerGeneratedILModules |> List.map (fun ((ccu, ilOrigScopeRef, ilModule), (_, localProvAssemStaticLinkInfo)) -> + providerGeneratedILModules + |> List.map (fun ((ccu, ilOrigScopeRef, ilModule), (_, localProvAssemStaticLinkInfo)) -> let ilAssemStaticLinkMap = - dict [ for _, (_, provAssemStaticLinkInfo) in providerGeneratedILModules do - for KeyValue(k, v) in provAssemStaticLinkInfo.ILTypeMap do - yield (k, v) - for KeyValue(k, v) in localProvAssemStaticLinkInfo.ILTypeMap do - yield (ILTypeRef.Create(ILScopeRef.Local, k.Enclosing, k.Name), v) ] + dict + [ + for _, (_, provAssemStaticLinkInfo) in providerGeneratedILModules do + for KeyValue (k, v) in provAssemStaticLinkInfo.ILTypeMap do + (k, v) + for KeyValue (k, v) in localProvAssemStaticLinkInfo.ILTypeMap do + (ILTypeRef.Create(ILScopeRef.Local, k.Enclosing, k.Name), v) + ] let ilModule = - ilModule |> Morphs.morphILTypeRefsInILModuleMemoized (fun tref -> - if debugStaticLinking then printfn "deciding whether to rewrite type ref %A" tref.QualifiedName - let ok, v = ilAssemStaticLinkMap.TryGetValue tref - if ok then - if debugStaticLinking then printfn "rewriting type ref %A to %A" tref.QualifiedName v.QualifiedName - v - else - tref) + ilModule + |> Morphs.morphILTypeRefsInILModuleMemoized (fun tref -> + if debugStaticLinking then + printfn "deciding whether to rewrite type ref %A" tref.QualifiedName + + match ilAssemStaticLinkMap.TryGetValue tref with + | true, v -> + if debugStaticLinking then + printfn "rewriting type ref %A to %A" tref.QualifiedName v.QualifiedName + + v + | _ -> tref) + (ccu, ilOrigScopeRef, ilModule)) // Relocate provider generated type definitions into the expected shape for the [] declarations in an assembly let providerGeneratedILModules, ilxMainModule = - // Build a dictionary of all remapped IL type defs - let ilOrigTyRefsForProviderGeneratedTypesToRelocate = - let rec walk acc (ProviderGeneratedType(ilOrigTyRef, _, xs) as node) = List.fold walk ((ilOrigTyRef, node) :: acc) xs - dict (Seq.fold walk [] tcImports.ProviderGeneratedTypeRoots) - - // Build a dictionary of all IL type defs, mapping ilOrigTyRef --> ilTypeDef - let allTypeDefsInProviderGeneratedAssemblies = - let rec loop ilOrigTyRef (ilTypeDef: ILTypeDef) = - seq { yield (ilOrigTyRef, ilTypeDef) - for ntdef in ilTypeDef.NestedTypes do - yield! loop (mkILTyRefInTyRef (ilOrigTyRef, ntdef.Name)) ntdef } - dict [ - for _ccu, ilOrigScopeRef, ilModule in providerGeneratedILModules do - for td in ilModule.TypeDefs do - yield! loop (mkILTyRef (ilOrigScopeRef, td.Name)) td ] - - - // Debugging output - if debugStaticLinking then - for ProviderGeneratedType(ilOrigTyRef, _, _) in tcImports.ProviderGeneratedTypeRoots do - printfn "Have [] root '%s'" ilOrigTyRef.QualifiedName - - // Build the ILTypeDefs for generated types, starting with the roots - let generatedILTypeDefs = - let rec buildRelocatedGeneratedType (ProviderGeneratedType(ilOrigTyRef, ilTgtTyRef, ch)) = - let isNested = not (isNil ilTgtTyRef.Enclosing) - match allTypeDefsInProviderGeneratedAssemblies.TryGetValue ilOrigTyRef with - | true, ilOrigTypeDef -> - if debugStaticLinking then printfn "Relocating %s to %s " ilOrigTyRef.QualifiedName ilTgtTyRef.QualifiedName - let ilOrigTypeDef = + // Build a dictionary of all remapped IL type defs + let ilOrigTyRefsForProviderGeneratedTypesToRelocate = + let rec walk acc (ProviderGeneratedType (ilOrigTyRef, _, xs) as node) = + List.fold walk ((ilOrigTyRef, node) :: acc) xs + + dict (Seq.fold walk [] tcImports.ProviderGeneratedTypeRoots) + + // Build a dictionary of all IL type defs, mapping ilOrigTyRef --> ilTypeDef + let allTypeDefsInProviderGeneratedAssemblies = + let rec loop ilOrigTyRef (ilTypeDef: ILTypeDef) = + seq { + (ilOrigTyRef, ilTypeDef) + + for ntdef in ilTypeDef.NestedTypes do + yield! loop (mkILTyRefInTyRef (ilOrigTyRef, ntdef.Name)) ntdef + } + + dict + [ + for _ccu, ilOrigScopeRef, ilModule in providerGeneratedILModules do + for td in ilModule.TypeDefs do + yield! loop (mkILTyRef (ilOrigScopeRef, td.Name)) td + ] + + // Debugging output + if debugStaticLinking then + for ProviderGeneratedType (ilOrigTyRef, _, _) in tcImports.ProviderGeneratedTypeRoots do + printfn "Have [] root '%s'" ilOrigTyRef.QualifiedName + + // Build the ILTypeDefs for generated types, starting with the roots + let generatedILTypeDefs = + let rec buildRelocatedGeneratedType (ProviderGeneratedType (ilOrigTyRef, ilTgtTyRef, ch)) = + let isNested = not (isNil ilTgtTyRef.Enclosing) + + match allTypeDefsInProviderGeneratedAssemblies.TryGetValue ilOrigTyRef with + | true, ilOrigTypeDef -> + if debugStaticLinking then + printfn "Relocating %s to %s " ilOrigTyRef.QualifiedName ilTgtTyRef.QualifiedName + + let ilOrigTypeDef = if isNested then + ilOrigTypeDef.WithAccess( + match ilOrigTypeDef.Access with + | ILTypeDefAccess.Public -> ILTypeDefAccess.Nested ILMemberAccess.Public + | ILTypeDefAccess.Private -> ILTypeDefAccess.Nested ILMemberAccess.Private + | _ -> ilOrigTypeDef.Access + ) + else ilOrigTypeDef - .WithAccess(match ilOrigTypeDef.Access with - | ILTypeDefAccess.Public -> ILTypeDefAccess.Nested ILMemberAccess.Public - | ILTypeDefAccess.Private -> ILTypeDefAccess.Nested ILMemberAccess.Private - | _ -> ilOrigTypeDef.Access) - else ilOrigTypeDef - ilOrigTypeDef.With(name = ilTgtTyRef.Name, - nestedTypes = mkILTypeDefs (List.map buildRelocatedGeneratedType ch)) - | _ -> - // If there is no matching IL type definition, then make a simple container class - if debugStaticLinking then - printfn "Generating simple class '%s' because we didn't find an original type '%s' in a provider generated assembly" - ilTgtTyRef.QualifiedName ilOrigTyRef.QualifiedName - - let access = (if isNested then ILTypeDefAccess.Nested ILMemberAccess.Public else ILTypeDefAccess.Public) - let tdefs = mkILTypeDefs (List.map buildRelocatedGeneratedType ch) - mkILSimpleClass ilGlobals (ilTgtTyRef.Name, access, emptyILMethods, emptyILFields, tdefs, emptyILProperties, emptyILEvents, emptyILCustomAttrs, ILTypeInit.OnAny) - - [ for ProviderGeneratedType(_, ilTgtTyRef, _) as node in tcImports.ProviderGeneratedTypeRoots do - yield (ilTgtTyRef, buildRelocatedGeneratedType node) ] - - // Implant all the generated type definitions into the ilxMainModule (generating a new ilxMainModule) - let ilxMainModule = - - /// Split the list into left, middle and right parts at the first element satisfying 'p'. If no element matches return - /// 'None' for the middle part. - let trySplitFind p xs = - let rec loop xs acc = - match xs with - | [] -> List.rev acc, None, [] - | h :: t -> if p h then List.rev acc, Some h, t else loop t (h :: acc) - loop xs [] - - /// Implant the (nested) type definition 'td' at path 'enc' in 'tdefs'. - let rec implantTypeDef isNested (tdefs: ILTypeDefs) (enc: string list) (td: ILTypeDef) = - match enc with - | [] -> addILTypeDef td tdefs - | h :: t -> - let tdefs = tdefs.AsList() - let ltdefs, htd, rtdefs = - match tdefs |> trySplitFind (fun td -> td.Name = h) with - | ltdefs, None, rtdefs -> - let access = if isNested then ILTypeDefAccess.Nested ILMemberAccess.Public else ILTypeDefAccess.Public - let fresh = mkILSimpleClass ilGlobals (h, access, emptyILMethods, emptyILFields, emptyILTypeDefs, emptyILProperties, emptyILEvents, emptyILCustomAttrs, ILTypeInit.OnAny) - (ltdefs, fresh, rtdefs) - | ltdefs, Some htd, rtdefs -> - (ltdefs, htd, rtdefs) - let htd = htd.With(nestedTypes = implantTypeDef true htd.NestedTypes t td) - mkILTypeDefs (ltdefs @ [htd] @ rtdefs) - - let newTypeDefs = - (ilxMainModule.TypeDefs, generatedILTypeDefs) ||> List.fold (fun acc (ilTgtTyRef, td) -> - if debugStaticLinking then printfn "implanting '%s' at '%s'" td.Name ilTgtTyRef.QualifiedName - implantTypeDef false acc ilTgtTyRef.Enclosing td) - { ilxMainModule with TypeDefs = newTypeDefs } - - // Remove any ILTypeDefs from the provider generated modules if they have been relocated because of a [] declaration. - let providerGeneratedILModules = - providerGeneratedILModules |> List.map (fun (ccu, ilOrigScopeRef, ilModule) -> - let ilTypeDefsAfterRemovingRelocatedTypes = - let rec rw enc (tdefs: ILTypeDefs) = - mkILTypeDefs - [ for tdef in tdefs do - let ilOrigTyRef = mkILNestedTyRef (ilOrigScopeRef, enc, tdef.Name) - if not (ilOrigTyRefsForProviderGeneratedTypesToRelocate.ContainsKey ilOrigTyRef) then - if debugStaticLinking then printfn "Keep provided type %s in place because it wasn't relocated" ilOrigTyRef.QualifiedName - yield tdef.With(nestedTypes = rw (enc@[tdef.Name]) tdef.NestedTypes) ] - rw [] ilModule.TypeDefs - (ccu, { ilModule with TypeDefs = ilTypeDefsAfterRemovingRelocatedTypes })) - - providerGeneratedILModules, ilxMainModule - - Morphs.disableMorphCustomAttributeData() + + ilOrigTypeDef.With(name = ilTgtTyRef.Name, nestedTypes = mkILTypeDefs (List.map buildRelocatedGeneratedType ch)) + | _ -> + // If there is no matching IL type definition, then make a simple container class + if debugStaticLinking then + printfn + "Generating simple class '%s' because we didn't find an original type '%s' in a provider generated assembly" + ilTgtTyRef.QualifiedName + ilOrigTyRef.QualifiedName + + let access = + (if isNested then + ILTypeDefAccess.Nested ILMemberAccess.Public + else + ILTypeDefAccess.Public) + + let tdefs = mkILTypeDefs (List.map buildRelocatedGeneratedType ch) + + mkILSimpleClass + ilGlobals + (ilTgtTyRef.Name, + access, + emptyILMethods, + emptyILFields, + tdefs, + emptyILProperties, + emptyILEvents, + emptyILCustomAttrs, + ILTypeInit.OnAny) + + [ + for ProviderGeneratedType (_, ilTgtTyRef, _) as node in tcImports.ProviderGeneratedTypeRoots do + (ilTgtTyRef, buildRelocatedGeneratedType node) + ] + + // Implant all the generated type definitions into the ilxMainModule (generating a new ilxMainModule) + let ilxMainModule = + + let newTypeDefs = + (ilxMainModule.TypeDefs, generatedILTypeDefs) + ||> List.fold (fun acc (ilTgtTyRef, td) -> + if debugStaticLinking then + printfn "implanting '%s' at '%s'" td.Name ilTgtTyRef.QualifiedName + + implantTypeDef ilGlobals false acc ilTgtTyRef.Enclosing td) + + { ilxMainModule with + TypeDefs = newTypeDefs + } + + // Remove any ILTypeDefs from the provider generated modules if they have been relocated because of a [] declaration. + let providerGeneratedILModules = + providerGeneratedILModules + |> List.map (fun (ccu, ilOrigScopeRef, ilModule) -> + let ilTypeDefsAfterRemovingRelocatedTypes = + let rec rw enc (tdefs: ILTypeDefs) = + mkILTypeDefs + [ + for tdef in tdefs do + let ilOrigTyRef = mkILNestedTyRef (ilOrigScopeRef, enc, tdef.Name) + + if not (ilOrigTyRefsForProviderGeneratedTypesToRelocate.ContainsKey ilOrigTyRef) then + if debugStaticLinking then + printfn + "Keep provided type %s in place because it wasn't relocated" + ilOrigTyRef.QualifiedName + + tdef.With(nestedTypes = rw (enc @ [ tdef.Name ]) tdef.NestedTypes) + ] + + rw [] ilModule.TypeDefs + + (ccu, + { ilModule with + TypeDefs = ilTypeDefsAfterRemovingRelocatedTypes + })) + + providerGeneratedILModules, ilxMainModule + + Morphs.disableMorphCustomAttributeData () #else let providerGeneratedILModules = [] #endif // Glue all this stuff into ilxMainModule let ilxMainModule, rewriteExternalRefsToLocalRefs = - StaticLinkILModules (tcConfig, ilGlobals, tcImports, ilxMainModule, dependentILModules @ providerGeneratedILModules) + StaticLinkILModules(tcConfig, ilGlobals, tcImports, ilxMainModule, dependentILModules @ providerGeneratedILModules) // Rewrite type and assembly references let ilxMainModule = - let isMscorlib = ilGlobals.primaryAssemblyName = PrimaryAssembly.Mscorlib.Name - let validateTargetPlatform (scopeRef : ILScopeRef) = - let name = getNameOfScopeRef scopeRef - if (not isMscorlib && name = PrimaryAssembly.Mscorlib.Name) then - error (Error(FSComp.SR.fscStaticLinkingNoProfileMismatches(), rangeCmdArgs)) - scopeRef - let rewriteAssemblyRefsToMatchLibraries = NormalizeAssemblyRefs (ctok, ilGlobals, tcImports) - Morphs.morphILTypeRefsInILModuleMemoized (Morphs.morphILScopeRefsInILTypeRef (validateTargetPlatform >> rewriteExternalRefsToLocalRefs >> rewriteAssemblyRefsToMatchLibraries)) ilxMainModule + let isMscorlib = ilGlobals.primaryAssemblyName = PrimaryAssembly.Mscorlib.Name + + let validateTargetPlatform (scopeRef: ILScopeRef) = + let name = getNameOfScopeRef scopeRef + + if (not isMscorlib && name = PrimaryAssembly.Mscorlib.Name) then + error (Error(FSComp.SR.fscStaticLinkingNoProfileMismatches (), rangeCmdArgs)) + + scopeRef + + let rewriteAssemblyRefsToMatchLibraries = + NormalizeAssemblyRefs(ctok, ilGlobals, tcImports) + + Morphs.morphILTypeRefsInILModuleMemoized + (Morphs.morphILScopeRefsInILTypeRef ( + validateTargetPlatform + >> rewriteExternalRefsToLocalRefs + >> rewriteAssemblyRefsToMatchLibraries + )) + ilxMainModule ilxMainModule) diff --git a/src/Compiler/Driver/XmlDocFileWriter.fs b/src/Compiler/Driver/XmlDocFileWriter.fs index 813dad3163c..97125744ace 100644 --- a/src/Compiler/Driver/XmlDocFileWriter.fs +++ b/src/Compiler/Driver/XmlDocFileWriter.fs @@ -25,31 +25,31 @@ module XmlDocWriter = let doTyconSig ptext (tc: Tycon) = if hasDoc tc.XmlDoc then - tc.XmlDocSig <- XmlDocSigOfTycon [ptext; tc.CompiledName] + tc.XmlDocSig <- XmlDocSigOfTycon [ ptext; tc.CompiledName ] for vref in tc.MembersOfFSharpTyconSorted do doValSig ptext vref.Deref for uc in tc.UnionCasesArray do if hasDoc uc.XmlDoc then - uc.XmlDocSig <- XmlDocSigOfUnionCase [ptext; tc.CompiledName; uc.Id.idText] + uc.XmlDocSig <- XmlDocSigOfUnionCase [ ptext; tc.CompiledName; uc.Id.idText ] for field in uc.RecdFieldsArray do if hasDoc field.XmlDoc then // union case fields are exposed as properties - field.XmlDocSig <- XmlDocSigOfProperty [ptext; tc.CompiledName; uc.Id.idText; field.Id.idText] + field.XmlDocSig <- XmlDocSigOfProperty [ ptext; tc.CompiledName; uc.Id.idText; field.Id.idText ] for rf in tc.AllFieldsArray do if hasDoc rf.XmlDoc then rf.XmlDocSig <- if tc.IsRecordTycon && not rf.IsStatic then // represents a record field, which is exposed as a property - XmlDocSigOfProperty [ptext; tc.CompiledName; rf.Id.idText] + XmlDocSigOfProperty [ ptext; tc.CompiledName; rf.Id.idText ] else - XmlDocSigOfField [ptext; tc.CompiledName; rf.Id.idText] + XmlDocSigOfField [ ptext; tc.CompiledName; rf.Id.idText ] let doModuleMemberSig path (m: ModuleOrNamespace) = - m.XmlDocSig <- XmlDocSigOfSubModul [path] + m.XmlDocSig <- XmlDocSigOfSubModul [ path ] let rec doModuleSig path (mspec: ModuleOrNamespace) = let mtype = mspec.ModuleOrNamespaceType @@ -59,17 +59,16 @@ module XmlDocWriter = match path with | None -> Some "" | Some "" -> Some mspec.LogicalName - | Some p -> Some (p+"."+mspec.LogicalName) + | Some p -> Some(p + "." + mspec.LogicalName) let ptext = defaultArg path "" - if mspec.IsModule then - doModuleMemberSig ptext mspec + if mspec.IsModule then doModuleMemberSig ptext mspec let vals = mtype.AllValsAndMembers |> Seq.toList - |> List.filter (fun x -> not x.IsCompilerGenerated) + |> List.filter (fun x -> not x.IsCompilerGenerated) |> List.filter (fun x -> x.MemberInfo.IsNone || x.IsExtensionMember) mtype.ModuleAndNamespaceDefinitions |> List.iter (doModuleSig path) @@ -80,8 +79,8 @@ module XmlDocWriter = doModuleSig None generatedCcu.Contents let WriteXmlDocFile (g, assemblyName, generatedCcu: CcuThunk, xmlFile) = - if not (FileSystemUtils.checkSuffix xmlFile "xml" ) then - error(Error(FSComp.SR.docfileNoXmlSuffix(), Range.rangeStartup)) + if not (FileSystemUtils.checkSuffix xmlFile "xml") then + error (Error(FSComp.SR.docfileNoXmlSuffix (), Range.rangeStartup)) let mutable members = [] @@ -90,18 +89,17 @@ module XmlDocWriter = let doc = xmlDoc.GetXmlText() members <- (id, doc) :: members - let doVal (v: Val) = - addMember v.XmlDocSig v.XmlDoc + let doVal (v: Val) = addMember v.XmlDocSig v.XmlDoc - let doField (rf: RecdField) = - addMember rf.XmlDocSig rf.XmlDoc + let doField (rf: RecdField) = addMember rf.XmlDocSig rf.XmlDoc let doUnionCase (uc: UnionCase) = addMember uc.XmlDocSig uc.XmlDoc + for field in uc.RecdFieldsArray do addMember field.XmlDocSig field.XmlDoc - let doTycon (tc: Tycon) = + let doTycon (tc: Tycon) = addMember tc.XmlDocSig tc.XmlDoc for vref in tc.MembersOfFSharpTyconSorted do @@ -114,18 +112,16 @@ module XmlDocWriter = for rf in tc.AllFieldsArray do doField rf - let modulMember (m: ModuleOrNamespace) = - addMember m.XmlDocSig m.XmlDoc + let modulMember (m: ModuleOrNamespace) = addMember m.XmlDocSig m.XmlDoc let rec doModule (mspec: ModuleOrNamespace) = let mtype = mspec.ModuleOrNamespaceType - if mspec.IsModule then - modulMember mspec + if mspec.IsModule then modulMember mspec let vals = mtype.AllValsAndMembers |> Seq.toList - |> List.filter (fun x -> not x.IsCompilerGenerated) + |> List.filter (fun x -> not x.IsCompilerGenerated) |> List.filter (fun x -> x.MemberInfo.IsNone || x.IsExtensionMember) List.iter doModule mtype.ModuleAndNamespaceDefinitions @@ -143,9 +139,9 @@ module XmlDocWriter = fprintfn os "" for (nm, doc) in members do - fprintfn os "" nm - fprintfn os "%s" doc - fprintfn os "" + fprintfn os "" nm + fprintfn os "%s" doc + fprintfn os "" fprintfn os "" fprintfn os "" diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 7b484a41fee..c6ae4d83b67 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -76,41 +76,50 @@ type DiagnosticsLoggerUpToMaxErrors(tcConfigB: TcConfigBuilder, exiter: Exiter, override _.ErrorCount = errors override x.DiagnosticSink(diagnostic, severity) = - if ReportDiagnosticAsError tcConfigB.diagnosticsOptions (diagnostic, severity) then - if errors >= tcConfigB.maxErrors then - x.HandleTooManyErrors(FSComp.SR.fscTooManyErrors()) - exiter.Exit 1 - - x.HandleIssue(tcConfigB, diagnostic, FSharpDiagnosticSeverity.Error) + if ReportDiagnosticAsError tcConfigB.diagnosticsOptions (diagnostic, severity) then + if errors >= tcConfigB.maxErrors then + x.HandleTooManyErrors(FSComp.SR.fscTooManyErrors ()) + exiter.Exit 1 - errors <- errors + 1 + x.HandleIssue(tcConfigB, diagnostic, FSharpDiagnosticSeverity.Error) - match diagnostic.Exception, tcConfigB.simulateException with - | InternalError (msg, _), None - | Failure msg, None -> Debug.Assert(false, sprintf "Bug in compiler: %s\n%s" msg (diagnostic.Exception.ToString())) - | :? KeyNotFoundException, None -> Debug.Assert(false, sprintf "Lookup exception in compiler: %s" (diagnostic.Exception.ToString())) - | _ -> () + errors <- errors + 1 - elif ReportDiagnosticAsWarning tcConfigB.diagnosticsOptions (diagnostic, severity) then - x.HandleIssue(tcConfigB, diagnostic, FSharpDiagnosticSeverity.Warning) + match diagnostic.Exception, tcConfigB.simulateException with + | InternalError (msg, _), None + | Failure msg, None -> Debug.Assert(false, sprintf "Bug in compiler: %s\n%s" msg (diagnostic.Exception.ToString())) + | :? KeyNotFoundException, None -> + Debug.Assert(false, sprintf "Lookup exception in compiler: %s" (diagnostic.Exception.ToString())) + | _ -> () - elif ReportDiagnosticAsInfo tcConfigB.diagnosticsOptions (diagnostic, severity) then - x.HandleIssue(tcConfigB, diagnostic, severity) + elif ReportDiagnosticAsWarning tcConfigB.diagnosticsOptions (diagnostic, severity) then + x.HandleIssue(tcConfigB, diagnostic, FSharpDiagnosticSeverity.Warning) + elif ReportDiagnosticAsInfo tcConfigB.diagnosticsOptions (diagnostic, severity) then + x.HandleIssue(tcConfigB, diagnostic, severity) /// Create an error logger that counts and prints errors -let ConsoleDiagnosticsLoggerUpToMaxErrors (tcConfigB: TcConfigBuilder, exiter : Exiter) = +let ConsoleDiagnosticsLoggerUpToMaxErrors (tcConfigB: TcConfigBuilder, exiter: Exiter) = { new DiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter, "ConsoleDiagnosticsLoggerUpToMaxErrors") with - member _.HandleTooManyErrors(text : string) = - DoWithDiagnosticColor FSharpDiagnosticSeverity.Warning (fun () -> Printf.eprintfn "%s" text) + member _.HandleTooManyErrors(text: string) = + DoWithDiagnosticColor FSharpDiagnosticSeverity.Warning (fun () -> Printf.eprintfn "%s" text) + + member _.HandleIssue(tcConfigB, err, severity) = + DoWithDiagnosticColor severity (fun () -> + let diagnostic = + OutputDiagnostic( + tcConfigB.implicitIncludeDir, + tcConfigB.showFullPaths, + tcConfigB.flatErrors, + tcConfigB.diagnosticStyle, + severity + ) - member _.HandleIssue(tcConfigB, err, severity) = - DoWithDiagnosticColor severity (fun () -> - let diagnostic = OutputDiagnostic (tcConfigB.implicitIncludeDir, tcConfigB.showFullPaths, tcConfigB.flatErrors, tcConfigB.diagnosticStyle, severity) - writeViaBuffer stderr diagnostic err - stderr.WriteLine()) - } :> DiagnosticsLogger + writeViaBuffer stderr diagnostic err + stderr.WriteLine()) + } + :> DiagnosticsLogger /// This error logger delays the messages it receives. At the end, call ForwardDelayedDiagnostics /// to send the held messages. @@ -118,13 +127,15 @@ type DelayAndForwardDiagnosticsLogger(exiter: Exiter, diagnosticsLoggerProvider: inherit CapturingDiagnosticsLogger("DelayAndForwardDiagnosticsLogger") member x.ForwardDelayedDiagnostics(tcConfigB: TcConfigBuilder) = - let diagnosticsLogger = diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + let diagnosticsLogger = + diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + x.CommitDelayedDiagnostics diagnosticsLogger -and [] - DiagnosticsLoggerProvider() = +and [] DiagnosticsLoggerProvider() = - member this.CreateDelayAndForwardLogger exiter = DelayAndForwardDiagnosticsLogger(exiter, this) + member this.CreateDelayAndForwardLogger exiter = + DelayAndForwardDiagnosticsLogger(exiter, this) abstract CreateDiagnosticsLoggerUpToMaxErrors: tcConfigBuilder: TcConfigBuilder * exiter: Exiter -> DiagnosticsLogger @@ -137,16 +148,42 @@ type ConsoleLoggerProvider() = ConsoleDiagnosticsLoggerUpToMaxErrors(tcConfigBuilder, exiter) /// Notify the exiter if any error has occurred -let AbortOnError (diagnosticsLogger: DiagnosticsLogger, exiter : Exiter) = - if diagnosticsLogger.ErrorCount > 0 then - exiter.Exit 1 - -let TypeCheck (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger: DiagnosticsLogger, assemblyName, niceNameGen, tcEnv0, openDecls0, inputs, exiter: Exiter) = +let AbortOnError (diagnosticsLogger: DiagnosticsLogger, exiter: Exiter) = + if diagnosticsLogger.ErrorCount > 0 then exiter.Exit 1 + +let TypeCheck + ( + ctok, + tcConfig, + tcImports, + tcGlobals, + diagnosticsLogger: DiagnosticsLogger, + assemblyName, + niceNameGen, + tcEnv0, + openDecls0, + inputs, + exiter: Exiter + ) = try - if isNil inputs then error(Error(FSComp.SR.fscNoImplementationFiles(), rangeStartup)) + if isNil inputs then + error (Error(FSComp.SR.fscNoImplementationFiles (), rangeStartup)) + let ccuName = assemblyName - let tcInitialState = GetInitialTcState (rangeStartup, ccuName, tcConfig, tcGlobals, tcImports, niceNameGen, tcEnv0, openDecls0) - CheckClosedInputSet (ctok, (fun () -> diagnosticsLogger.ErrorCount > 0), tcConfig, tcImports, tcGlobals, None, tcInitialState, inputs) + + let tcInitialState = + GetInitialTcState(rangeStartup, ccuName, tcConfig, tcGlobals, tcImports, niceNameGen, tcEnv0, openDecls0) + + CheckClosedInputSet( + ctok, + (fun () -> diagnosticsLogger.ErrorCount > 0), + tcConfig, + tcImports, + tcGlobals, + None, + tcInitialState, + inputs + ) with exn -> errorRecovery exn rangeStartup exiter.Exit 1 @@ -162,34 +199,38 @@ let TypeCheck (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger: Diagnost /// copied to the output folder, for example (except perhaps FSharp.Core.dll). /// /// NOTE: there is similar code in IncrementalBuilder.fs and this code should really be reconciled with that -let AdjustForScriptCompile(tcConfigB: TcConfigBuilder, commandLineSourceFiles, lexResourceManager, dependencyProvider) = +let AdjustForScriptCompile (tcConfigB: TcConfigBuilder, commandLineSourceFiles, lexResourceManager, dependencyProvider) = let combineFilePath file = try - if FileSystem.IsPathRootedShim file then file - else Path.Combine(tcConfigB.implicitIncludeDir, file) + if FileSystem.IsPathRootedShim file then + file + else + Path.Combine(tcConfigB.implicitIncludeDir, file) with _ -> error (Error(FSComp.SR.pathIsInvalid file, rangeStartup)) - let commandLineSourceFiles = - commandLineSourceFiles - |> List.map combineFilePath + let commandLineSourceFiles = commandLineSourceFiles |> List.map combineFilePath // Script compilation is active if the last item being compiled is a script and --noframework has not been specified let mutable allSources = [] - let tcConfig = TcConfig.Create(tcConfigB, validate=false) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) let AddIfNotPresent (fileName: string) = - if not(allSources |> List.contains fileName) then + if not (allSources |> List.contains fileName) then allSources <- fileName :: allSources let AppendClosureInformation fileName = if IsScript fileName then let closure = - LoadClosure.ComputeClosureOfScriptFiles - (tcConfig, [fileName, rangeStartup], CodeContext.Compilation, - lexResourceManager, dependencyProvider) + LoadClosure.ComputeClosureOfScriptFiles( + tcConfig, + [ fileName, rangeStartup ], + CodeContext.Compilation, + lexResourceManager, + dependencyProvider + ) // Record the new references (non-framework) references from the analysis of the script. (The full resolutions are recorded // as the corresponding #I paths used to resolve them are local to the scripts and not added to the tcConfigB - they are @@ -197,24 +238,39 @@ let AdjustForScriptCompile(tcConfigB: TcConfigBuilder, commandLineSourceFiles, l let references = closure.References |> List.collect snd - |> List.filter (fun r -> not (equals r.originalReference.Range range0) && not (equals r.originalReference.Range rangeStartup)) + |> List.filter (fun r -> + not (equals r.originalReference.Range range0) + && not (equals r.originalReference.Range rangeStartup)) - references |> List.iter (fun r -> tcConfigB.AddReferencedAssemblyByPath(r.originalReference.Range, r.resolvedPath)) + references + |> List.iter (fun r -> tcConfigB.AddReferencedAssemblyByPath(r.originalReference.Range, r.resolvedPath)) // Also record the other declarations from the script. - closure.NoWarns |> List.collect (fun (n, ms) -> ms|>List.map(fun m->m, n)) |> List.iter (fun (x,m) -> tcConfigB.TurnWarningOff(x, m)) + closure.NoWarns + |> List.collect (fun (n, ms) -> ms |> List.map (fun m -> m, n)) + |> List.iter (fun (x, m) -> tcConfigB.TurnWarningOff(x, m)) + closure.SourceFiles |> List.map fst |> List.iter AddIfNotPresent closure.AllRootFileDiagnostics |> List.iter diagnosticSink // If there is a target framework for the script then push that as a requirement into the overall compilation and add all the framework references implied // by the script too. - tcConfigB.SetPrimaryAssembly (if closure.UseDesktopFramework then PrimaryAssembly.Mscorlib else PrimaryAssembly.System_Runtime) + let primaryAssembly = + if closure.UseDesktopFramework then + PrimaryAssembly.Mscorlib + else + PrimaryAssembly.System_Runtime + + tcConfigB.SetPrimaryAssembly primaryAssembly if tcConfigB.implicitlyReferenceDotNetAssemblies then let references = closure.References |> List.collect snd - references |> List.iter (fun r -> tcConfigB.AddReferencedAssemblyByPath(r.originalReference.Range, r.resolvedPath)) - else AddIfNotPresent fileName + for reference in references do + tcConfigB.AddReferencedAssemblyByPath(reference.originalReference.Range, reference.resolvedPath) + + else + AddIfNotPresent fileName // Find closure of .fsx files. commandLineSourceFiles |> List.iter AppendClosureInformation @@ -225,33 +281,37 @@ let SetProcessThreadLocals tcConfigB = match tcConfigB.preferredUiLang with | Some s -> Thread.CurrentThread.CurrentUICulture <- CultureInfo(s) | None -> () + if tcConfigB.utf8output then Console.OutputEncoding <- Encoding.UTF8 let ProcessCommandLineFlags (tcConfigB: TcConfigBuilder, lcidFromCodePage, argv) = let mutable inputFilesRef = [] + let collect name = - if List.exists (FileSystemUtils.checkSuffix name) [".resx"] then - error(Error(FSComp.SR.fscResxSourceFileDeprecated name, rangeStartup)) + if List.exists (FileSystemUtils.checkSuffix name) [ ".resx" ] then + error (Error(FSComp.SR.fscResxSourceFileDeprecated name, rangeStartup)) else inputFilesRef <- name :: inputFilesRef + let abbrevArgs = GetAbbrevFlagSet tcConfigB true // This is where flags are interpreted by the command line fsc.exe. - ParseCompilerOptions (collect, GetCoreFscCompilerOptions tcConfigB, List.tail (PostProcessCompilerArgs abbrevArgs argv)) + ParseCompilerOptions(collect, GetCoreFscCompilerOptions tcConfigB, List.tail (PostProcessCompilerArgs abbrevArgs argv)) if not (tcConfigB.portablePDB || tcConfigB.embeddedPDB) then if tcConfigB.embedAllSource || (tcConfigB.embedSourceList |> isNil |> not) then - error(Error(FSComp.SR.optsEmbeddedSourceRequirePortablePDBs(), rangeCmdArgs)) + error (Error(FSComp.SR.optsEmbeddedSourceRequirePortablePDBs (), rangeCmdArgs)) + if not (String.IsNullOrEmpty(tcConfigB.sourceLink)) then - error(Error(FSComp.SR.optsSourceLinkRequirePortablePDBs(), rangeCmdArgs)) + error (Error(FSComp.SR.optsSourceLinkRequirePortablePDBs (), rangeCmdArgs)) if tcConfigB.debuginfo && not tcConfigB.portablePDB then if tcConfigB.deterministic then - error(Error(FSComp.SR.fscDeterministicDebugRequiresPortablePdb(), rangeCmdArgs)) + error (Error(FSComp.SR.fscDeterministicDebugRequiresPortablePdb (), rangeCmdArgs)) if tcConfigB.pathMap <> PathMap.empty then - error(Error(FSComp.SR.fscPathMapDebugRequiresPortablePdb(), rangeCmdArgs)) + error (Error(FSComp.SR.fscPathMapDebugRequiresPortablePdb (), rangeCmdArgs)) let inputFiles = List.rev inputFilesRef @@ -263,12 +323,18 @@ let ProcessCommandLineFlags (tcConfigB: TcConfigBuilder, lcidFromCodePage, argv) SetProcessThreadLocals tcConfigB (* step - get dll references *) - let dllFiles, sourceFiles = inputFiles |> List.map(fun p -> FileSystemUtils.trimQuotes p) |> List.partition FileSystemUtils.isDll + let dllFiles, sourceFiles = + inputFiles + |> List.map (fun p -> FileSystemUtils.trimQuotes p) + |> List.partition FileSystemUtils.isDll + match dllFiles with | [] -> () | h :: _ -> errorR (Error(FSComp.SR.fscReferenceOnCommandLine h, rangeStartup)) - dllFiles |> List.iter (fun f->tcConfigB.AddReferencedAssemblyByPath(rangeStartup, f)) + dllFiles + |> List.iter (fun f -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup, f)) + sourceFiles /// Write a .fsi file for the --sig option @@ -278,14 +344,26 @@ module InterfaceFileWriter = // * write one unified sig file to a given path, or // * write individual sig files to paths matching their impl files let denv = DisplayEnv.InitialForSigFileGeneration tcGlobals - let denv = { denv with shrinkOverloads = false; printVerboseSignatures = true } - let writeToFile os (CheckedImplFile (contents=mexpr)) = - writeViaBuffer os (fun os s -> Printf.bprintf os "%s\n\n" s) - (NicePrint.layoutImpliedSignatureOfModuleOrNamespace true denv infoReader AccessibleFromSomewhere range0 mexpr |> Display.squashTo 80 |> LayoutRender.showL) + let denv = + { denv with + shrinkOverloads = false + printVerboseSignatures = true + } + + let writeToFile os (CheckedImplFile (contents = mexpr)) = + writeViaBuffer + os + (fun os s -> Printf.bprintf os "%s\n\n" s) + (NicePrint.layoutImpliedSignatureOfModuleOrNamespace true denv infoReader AccessibleFromSomewhere range0 mexpr + |> Display.squashTo 80 + |> LayoutRender.showL) let writeHeader filePath os = - if filePath <> "" && not (List.exists (FileSystemUtils.checkSuffix filePath) FSharpIndentationAwareSyntaxFileSuffixes) then + if + filePath <> "" + && not (List.exists (FileSystemUtils.checkSuffix filePath) FSharpIndentationAwareSyntaxFileSuffixes) + then fprintfn os "#light" fprintfn os "" @@ -295,7 +373,9 @@ module InterfaceFileWriter = if tcConfig.printSignatureFile = "" then Console.Out else - FileSystem.OpenFileForWriteShim(tcConfig.printSignatureFile, FileMode.Create).GetWriter() + FileSystem + .OpenFileForWriteShim(tcConfig.printSignatureFile, FileMode.Create) + .GetWriter() writeHeader tcConfig.printSignatureFile os @@ -305,14 +385,16 @@ module InterfaceFileWriter = if tcConfig.printSignatureFile <> "" then os.Dispose() let extensionForFile (filePath: string) = - if (List.exists (FileSystemUtils.checkSuffix filePath) mlCompatSuffixes) then + if (List.exists (FileSystemUtils.checkSuffix filePath) FSharpMLCompatFileSuffixes) then ".mli" else ".fsi" let writeToSeparateFiles (declaredImpls: CheckedImplFile list) = - for CheckedImplFile (qualifiedNameOfFile=name) as impl in declaredImpls do - let fileName = Path.ChangeExtension(name.Range.FileName, extensionForFile name.Range.FileName) + for CheckedImplFile (qualifiedNameOfFile = name) as impl in declaredImpls do + let fileName = + Path.ChangeExtension(name.Range.FileName, extensionForFile name.Range.FileName) + printfn "writing impl file to %s" fileName use os = FileSystem.OpenFileForWriteShim(fileName, FileMode.Create).GetWriter() writeHeader fileName os @@ -331,36 +413,49 @@ module InterfaceFileWriter = // 1) Look into the referenced assemblies, if FSharp.Core.dll is specified, it will copy it to output directory. // 2) If not, but FSharp.Core.dll exists beside the compiler binaries, it will copy it to output directory. // 3) If not, it will produce an error. -let CopyFSharpCore(outFile: string, referencedDlls: AssemblyReference list) = +let CopyFSharpCore (outFile: string, referencedDlls: AssemblyReference list) = let outDir = Path.GetDirectoryName outFile let fsharpCoreAssemblyName = GetFSharpCoreLibraryName() + ".dll" let fsharpCoreDestinationPath = Path.Combine(outDir, fsharpCoreAssemblyName) + let copyFileIfDifferent src dest = - if not (FileSystem.FileExistsShim dest) || (FileSystem.GetCreationTimeShim src <> FileSystem.GetCreationTimeShim dest) then + if + not (FileSystem.FileExistsShim dest) + || (FileSystem.GetCreationTimeShim src <> FileSystem.GetCreationTimeShim dest) + then FileSystem.CopyShim(src, dest, true) - match referencedDlls |> Seq.tryFind (fun dll -> String.Equals(Path.GetFileName(dll.Text), fsharpCoreAssemblyName, StringComparison.CurrentCultureIgnoreCase)) with + let fsharpCoreReferences = + referencedDlls + |> Seq.tryFind (fun dll -> + String.Equals(Path.GetFileName(dll.Text), fsharpCoreAssemblyName, StringComparison.CurrentCultureIgnoreCase)) + + match fsharpCoreReferences with | Some referencedFsharpCoreDll -> copyFileIfDifferent referencedFsharpCoreDll.Text fsharpCoreDestinationPath | None -> - let executionLocation = - Assembly.GetExecutingAssembly().Location + let executionLocation = Assembly.GetExecutingAssembly().Location let compilerLocation = Path.GetDirectoryName executionLocation - let compilerFsharpCoreDllPath = Path.Combine(compilerLocation, fsharpCoreAssemblyName) + + let compilerFsharpCoreDllPath = + Path.Combine(compilerLocation, fsharpCoreAssemblyName) + if FileSystem.FileExistsShim compilerFsharpCoreDllPath then copyFileIfDifferent compilerFsharpCoreDllPath fsharpCoreDestinationPath else - errorR(Error(FSComp.SR.fsharpCoreNotFoundToBeCopied(), rangeCmdArgs)) + errorR (Error(FSComp.SR.fsharpCoreNotFoundToBeCopied (), rangeCmdArgs)) // Try to find an AssemblyVersion attribute let TryFindVersionAttribute g attrib attribName attribs deterministic = match AttributeHelpers.TryFindStringAttribute g attrib attribs with | Some versionString -> - if deterministic && versionString.Contains("*") then - errorR(Error(FSComp.SR.fscAssemblyWildcardAndDeterminism(attribName, versionString), rangeStartup)) - try Some (parseILVersion versionString) - with e -> - // Warning will be reported by CheckExpressions.fs - None + if deterministic && versionString.Contains("*") then + errorR (Error(FSComp.SR.fscAssemblyWildcardAndDeterminism (attribName, versionString), rangeStartup)) + + try + Some(parseILVersion versionString) + with e -> + // Warning will be reported by CheckExpressions.fs + None | _ -> None //---------------------------------------------------------------------------- @@ -370,7 +465,7 @@ let TryFindVersionAttribute g attrib attribName attribs deterministic = //----------------------------------------------------------------------------- [] -type Args<'T> = Args of 'T +type Args<'T> = Args of 'T /// First phase of compilation. /// - Set up console encoding and code page settings @@ -379,17 +474,28 @@ type Args<'T> = Args of 'T /// - Import assemblies /// - Parse source files /// - Check the inputs -let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, - reduceMemoryUsage: ReduceMemoryFlag, defaultCopyFSharpCore: CopyFSharpCoreFlag, - exiter: Exiter, diagnosticsLoggerProvider: DiagnosticsLoggerProvider, disposables: DisposablesTracker) = +let main1 + ( + ctok, + argv, + legacyReferenceResolver, + bannerAlreadyPrinted, + reduceMemoryUsage: ReduceMemoryFlag, + defaultCopyFSharpCore: CopyFSharpCoreFlag, + exiter: Exiter, + diagnosticsLoggerProvider: DiagnosticsLoggerProvider, + disposables: DisposablesTracker + ) = // See Bug 735819 let lcidFromCodePage = - if (Console.OutputEncoding.CodePage <> 65001) && - (Console.OutputEncoding.CodePage <> Thread.CurrentThread.CurrentUICulture.TextInfo.OEMCodePage) && - (Console.OutputEncoding.CodePage <> Thread.CurrentThread.CurrentUICulture.TextInfo.ANSICodePage) then - Thread.CurrentThread.CurrentUICulture <- CultureInfo("en-US") - Some 1033 + if (Console.OutputEncoding.CodePage <> 65001) + && (Console.OutputEncoding.CodePage + <> Thread.CurrentThread.CurrentUICulture.TextInfo.OEMCodePage) + && (Console.OutputEncoding.CodePage + <> Thread.CurrentThread.CurrentUICulture.TextInfo.ANSICodePage) then + Thread.CurrentThread.CurrentUICulture <- CultureInfo("en-US") + Some 1033 else None @@ -397,29 +503,34 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, let tryGetMetadataSnapshot = (fun _ -> None) - let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value + let defaultFSharpBinariesDir = + FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value let tcConfigB = - TcConfigBuilder.CreateNew(legacyReferenceResolver, + TcConfigBuilder.CreateNew( + legacyReferenceResolver, defaultFSharpBinariesDir, - reduceMemoryUsage=reduceMemoryUsage, - implicitIncludeDir=directoryBuildingFrom, - isInteractive=false, - isInvalidationSupported=false, - defaultCopyFSharpCore=defaultCopyFSharpCore, - tryGetMetadataSnapshot=tryGetMetadataSnapshot, - sdkDirOverride=None, - rangeForErrors=range0) + reduceMemoryUsage = reduceMemoryUsage, + implicitIncludeDir = directoryBuildingFrom, + isInteractive = false, + isInvalidationSupported = false, + defaultCopyFSharpCore = defaultCopyFSharpCore, + tryGetMetadataSnapshot = tryGetMetadataSnapshot, + sdkDirOverride = None, + rangeForErrors = range0 + ) // Preset: --optimize+ -g --tailcalls+ (see 4505) SetOptimizeSwitch tcConfigB OptionSwitch.On - SetDebugSwitch tcConfigB None OptionSwitch.Off + SetDebugSwitch tcConfigB None OptionSwitch.Off SetTailcallSwitch tcConfigB OptionSwitch.On // Now install a delayed logger to hold all errors from flags until after all flags have been parsed (for example, --vserrors) - let delayForFlagsLogger = diagnosticsLoggerProvider.CreateDelayAndForwardLogger exiter + let delayForFlagsLogger = + diagnosticsLoggerProvider.CreateDelayAndForwardLogger exiter - let _unwindEL_1 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> delayForFlagsLogger) + let _unwindEL_1 = + PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> delayForFlagsLogger) // Share intern'd strings across all lexing/parsing let lexResourceManager = Lexhelp.LexResourceManager() @@ -432,7 +543,7 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, // The ParseCompilerOptions function calls imperative function to process "real" args // Rather than start processing, just collect names, then process them. try - let files = ProcessCommandLineFlags (tcConfigB, lcidFromCodePage, argv) + let files = ProcessCommandLineFlags(tcConfigB, lcidFromCodePage, argv) AdjustForScriptCompile(tcConfigB, files, lexResourceManager, dependencyProvider) with e -> errorRecovery e rangeStartup @@ -442,8 +553,7 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, tcConfigB.conditionalDefines <- "COMPILED" :: tcConfigB.conditionalDefines // Display the banner text, if necessary - if not bannerAlreadyPrinted then - DisplayBannerText tcConfigB + if not bannerAlreadyPrinted then DisplayBannerText tcConfigB // Create tcGlobals and frameworkTcImports let outfile, pdbfile, assemblyName = @@ -462,16 +572,17 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, // If there's a problem building TcConfig, abort let tcConfig = try - TcConfig.Create(tcConfigB, validate=false) + TcConfig.Create(tcConfigB, validate = false) with e -> errorRecovery e rangeStartup delayForFlagsLogger.ForwardDelayedDiagnostics tcConfigB exiter.Exit 1 - let diagnosticsLogger = diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + let diagnosticsLogger = + diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) // Install the global error logger and never remove it. This logger does have all command-line flags considered. - let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) + let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) // Forward all errors from flags delayForFlagsLogger.CommitDelayedDiagnostics diagnosticsLogger @@ -483,14 +594,18 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, ReportTime tcConfig "Import mscorlib and FSharp.Core.dll" let foundationalTcConfigP = TcConfigProvider.Constant tcConfig - let sysRes, otherRes, knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) + let sysRes, otherRes, knownUnresolved = + TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) // Import basic assemblies - let tcGlobals, frameworkTcImports = - TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes) + let tcGlobals, frameworkTcImports = + TcImports.BuildFrameworkTcImports(foundationalTcConfigP, sysRes, otherRes) |> NodeCode.RunImmediateWithoutCancellation - let ilSourceDocs = [ for sourceFile in sourceFiles -> tcGlobals.memoize_file (FileIndex.fileIndexOfFile sourceFile)] + let ilSourceDocs = + [ + for sourceFile in sourceFiles -> tcGlobals.memoize_file (FileIndex.fileIndexOfFile sourceFile) + ] // Register framework tcImports to be disposed in future disposables.Register frameworkTcImports @@ -499,12 +614,23 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, ReportTime tcConfig "Parse inputs" use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - let createDiagnosticsLogger = (fun exiter -> diagnosticsLoggerProvider.CreateDelayAndForwardLogger(exiter) :> CapturingDiagnosticsLogger) + let createDiagnosticsLogger = + (fun exiter -> diagnosticsLoggerProvider.CreateDelayAndForwardLogger(exiter) :> CapturingDiagnosticsLogger) - let inputs = ParseInputFiles(tcConfig, lexResourceManager, sourceFiles, diagnosticsLogger, exiter, createDiagnosticsLogger, (*retryLocked*)false) + let inputs = + ParseInputFiles( + tcConfig, + lexResourceManager, + sourceFiles, + diagnosticsLogger, + exiter, + createDiagnosticsLogger (*retryLocked*) , + false + ) let inputs, _ = - (Map.empty, inputs) ||> List.mapFold (fun state (input, x) -> + (Map.empty, inputs) + ||> List.mapFold (fun state (input, x) -> let inputT, stateT = DeduplicateParsedInputModuleName state input (inputT, x), stateT) @@ -522,7 +648,8 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, // Apply any nowarn flags let tcConfig = - (tcConfig, inputs) ||> List.fold (fun z (input, sourceFileDirectory) -> + (tcConfig, inputs) + ||> List.fold (fun z (input, sourceFileDirectory) -> ApplyMetaCommandsFromInputToTcConfig(z, input, sourceFileDirectory, dependencyProvider)) let tcConfigP = TcConfigProvider.Constant tcConfig @@ -547,50 +674,99 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck - let tcEnv0, openDecls0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) + let tcEnv0, openDecls0 = + GetInitialTcEnv(assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) // Type check the inputs let inputs = inputs |> List.map fst let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = - TypeCheck(ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, assemblyName, NiceNameGenerator(), tcEnv0, openDecls0, inputs, exiter) + TypeCheck( + ctok, + tcConfig, + tcImports, + tcGlobals, + diagnosticsLogger, + assemblyName, + NiceNameGenerator(), + tcEnv0, + openDecls0, + inputs, + exiter + ) AbortOnError(diagnosticsLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, diagnosticsLogger, exiter, ilSourceDocs) + Args( + ctok, + tcGlobals, + tcImports, + frameworkTcImports, + tcState.Ccu, + typedAssembly, + topAttrs, + tcConfig, + outfile, + pdbfile, + assemblyName, + diagnosticsLogger, + exiter, + ilSourceDocs + ) /// Alternative first phase of compilation. This is for the compile-from-AST feature of FCS. /// - Import assemblies /// - Check the inputs let main1OfAst - (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, - outfile, pdbFile, dllReferences, - noframework, exiter: Exiter, + ( + ctok, + legacyReferenceResolver, + reduceMemoryUsage, + assemblyName, + target, + outfile, + pdbFile, + dllReferences, + noframework, + exiter: Exiter, diagnosticsLoggerProvider: DiagnosticsLoggerProvider, disposables: DisposablesTracker, - inputs: ParsedInput list) = + inputs: ParsedInput list + ) = let tryGetMetadataSnapshot = (fun _ -> None) let directoryBuildingFrom = Directory.GetCurrentDirectory() - let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value + let defaultFSharpBinariesDir = + FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value let tcConfigB = - TcConfigBuilder.CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir, - reduceMemoryUsage=reduceMemoryUsage, implicitIncludeDir=directoryBuildingFrom, - isInteractive=false, isInvalidationSupported=false, - defaultCopyFSharpCore=CopyFSharpCoreFlag.No, - tryGetMetadataSnapshot=tryGetMetadataSnapshot, - sdkDirOverride=None, - rangeForErrors=range0) + TcConfigBuilder.CreateNew( + legacyReferenceResolver, + defaultFSharpBinariesDir, + reduceMemoryUsage = reduceMemoryUsage, + implicitIncludeDir = directoryBuildingFrom, + isInteractive = false, + isInvalidationSupported = false, + defaultCopyFSharpCore = CopyFSharpCoreFlag.No, + tryGetMetadataSnapshot = tryGetMetadataSnapshot, + sdkDirOverride = None, + rangeForErrors = range0 + ) let primaryAssembly = // temporary workaround until https://github.com/dotnet/fsharp/pull/8043 is merged: // pick a primary assembly based on whether the developer included System>Runtime in the list of reference assemblies. // It's an ugly compromise used to avoid exposing primaryAssembly in the public api for this function. - let includesSystem_Runtime = dllReferences |> Seq.exists(fun f -> Path.GetFileName(f).Equals("system.runtime.dll",StringComparison.InvariantCultureIgnoreCase)) + let includesSystem_Runtime = + dllReferences + |> Seq.exists (fun f -> + Path + .GetFileName(f) + .Equals("system.runtime.dll", StringComparison.InvariantCultureIgnoreCase)) + if includesSystem_Runtime then PrimaryAssembly.System_Runtime else @@ -605,34 +781,44 @@ let main1OfAst // Preset: --optimize+ -g --tailcalls+ (see 4505) SetOptimizeSwitch tcConfigB OptionSwitch.On - SetDebugSwitch tcConfigB None ( - match pdbFile with - | Some _ -> OptionSwitch.On - | None -> OptionSwitch.Off) + + SetDebugSwitch + tcConfigB + None + (match pdbFile with + | Some _ -> OptionSwitch.On + | None -> OptionSwitch.Off) + SetTailcallSwitch tcConfigB OptionSwitch.On // Now install a delayed logger to hold all errors from flags until after all flags have been parsed (for example, --vserrors) - let delayForFlagsLogger = diagnosticsLoggerProvider.CreateDelayAndForwardLogger exiter - let _unwindEL_1 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> delayForFlagsLogger) + let delayForFlagsLogger = + diagnosticsLoggerProvider.CreateDelayAndForwardLogger exiter + + let _unwindEL_1 = + PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> delayForFlagsLogger) tcConfigB.conditionalDefines <- "COMPILED" :: tcConfigB.conditionalDefines // append assembly dependencies - dllReferences |> List.iter (fun ref -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup,ref)) + dllReferences + |> List.iter (fun ref -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup, ref)) // If there's a problem building TcConfig, abort let tcConfig = try - TcConfig.Create(tcConfigB,validate=false) + TcConfig.Create(tcConfigB, validate = false) with e -> delayForFlagsLogger.ForwardDelayedDiagnostics tcConfigB exiter.Exit 1 let dependencyProvider = new DependencyProvider() - let diagnosticsLogger = diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + + let diagnosticsLogger = + diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) // Install the global error logger and never remove it. This logger does have all command-line flags considered. - let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) + let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) // Forward all errors from flags delayForFlagsLogger.CommitDelayedDiagnostics diagnosticsLogger @@ -640,11 +826,13 @@ let main1OfAst // Resolve assemblies ReportTime tcConfig "Import mscorlib and FSharp.Core.dll" let foundationalTcConfigP = TcConfigProvider.Constant tcConfig - let sysRes, otherRes, knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) + + let sysRes, otherRes, knownUnresolved = + TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) // Import basic assemblies - let tcGlobals, frameworkTcImports = - TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes) + let tcGlobals, frameworkTcImports = + TcImports.BuildFrameworkTcImports(foundationalTcConfigP, sysRes, otherRes) |> NodeCode.RunImmediateWithoutCancellation // Register framework tcImports to be disposed in future @@ -653,14 +841,18 @@ let main1OfAst use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse let meta = Directory.GetCurrentDirectory() - let tcConfig = (tcConfig,inputs) ||> List.fold (fun tcc inp -> ApplyMetaCommandsFromInputToTcConfig (tcc, inp, meta, dependencyProvider)) + + let tcConfig = + (tcConfig, inputs) + ||> List.fold (fun tcc inp -> ApplyMetaCommandsFromInputToTcConfig(tcc, inp, meta, dependencyProvider)) + let tcConfigP = TcConfigProvider.Constant tcConfig // Import other assemblies ReportTime tcConfig "Import non-system references" - let tcImports = - TcImports.BuildNonFrameworkTcImports(tcConfigP, frameworkTcImports, otherRes, knownUnresolved, dependencyProvider) + let tcImports = + TcImports.BuildNonFrameworkTcImports(tcConfigP, frameworkTcImports, otherRes, knownUnresolved, dependencyProvider) |> NodeCode.RunImmediateWithoutCancellation // register tcImports to be disposed in future @@ -669,76 +861,171 @@ let main1OfAst // Build the initial type checking environment ReportTime tcConfig "Typecheck" use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck - let tcEnv0, openDecls0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) + + let tcEnv0, openDecls0 = + GetInitialTcEnv(assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) // Type check the inputs let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = - TypeCheck(ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, assemblyName, NiceNameGenerator(), tcEnv0, openDecls0, inputs, exiter) + TypeCheck( + ctok, + tcConfig, + tcImports, + tcGlobals, + diagnosticsLogger, + assemblyName, + NiceNameGenerator(), + tcEnv0, + openDecls0, + inputs, + exiter + ) AbortOnError(diagnosticsLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbFile, assemblyName, diagnosticsLogger, exiter, []) + Args( + ctok, + tcGlobals, + tcImports, + frameworkTcImports, + tcState.Ccu, + typedAssembly, + topAttrs, + tcConfig, + outfile, + pdbFile, + assemblyName, + diagnosticsLogger, + exiter, + [] + ) /// Second phase of compilation. /// - Write the signature file, check some attributes -let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu: CcuThunk, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, diagnosticsLogger, exiter: Exiter, ilSourceDocs)) = +let main2 + (Args (ctok, + tcGlobals, + tcImports: TcImports, + frameworkTcImports, + generatedCcu: CcuThunk, + typedImplFiles, + topAttrs, + tcConfig: TcConfig, + outfile, + pdbfile, + assemblyName, + diagnosticsLogger, + exiter: Exiter, + ilSourceDocs)) + = if tcConfig.typeCheckOnly then exiter.Exit 0 generatedCcu.Contents.SetAttribs(generatedCcu.Contents.Attribs @ topAttrs.assemblyAttrs) use unwindPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.CodeGen - let signingInfo = ValidateKeySigningAttributes (tcConfig, tcGlobals, topAttrs) + let signingInfo = ValidateKeySigningAttributes(tcConfig, tcGlobals, topAttrs) AbortOnError(diagnosticsLogger, exiter) // Build an updated diagnosticsLogger that filters according to the scopedPragmas. Then install // it as the updated global error logger and never remove it let oldLogger = diagnosticsLogger + let diagnosticsLogger = - let scopedPragmas = [ for CheckedImplFile (pragmas=pragmas) in typedImplFiles do yield! pragmas ] + let scopedPragmas = + [ + for CheckedImplFile (pragmas = pragmas) in typedImplFiles do + yield! pragmas + ] + GetDiagnosticsLoggerFilteringByScopedPragmas(true, scopedPragmas, tcConfig.diagnosticsOptions, oldLogger) let _unwindEL_3 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) // Try to find an AssemblyVersion attribute let assemVerFromAttrib = - match TryFindVersionAttribute tcGlobals "System.Reflection.AssemblyVersionAttribute" "AssemblyVersionAttribute" topAttrs.assemblyAttrs tcConfig.deterministic with + match + TryFindVersionAttribute + tcGlobals + "System.Reflection.AssemblyVersionAttribute" + "AssemblyVersionAttribute" + topAttrs.assemblyAttrs + tcConfig.deterministic + with | Some v -> - match tcConfig.version with - | VersionNone -> Some v - | _ -> warning(Error(FSComp.SR.fscAssemblyVersionAttributeIgnored(), rangeStartup)); None + match tcConfig.version with + | VersionNone -> Some v + | _ -> + warning (Error(FSComp.SR.fscAssemblyVersionAttributeIgnored (), rangeStartup)) + None | _ -> match tcConfig.version with - | VersionNone -> Some (ILVersionInfo (0us,0us,0us,0us)) //If no attribute was specified in source then version is 0.0.0.0 - | _ -> Some (tcConfig.version.GetVersionInfo tcConfig.implicitIncludeDir) + | VersionNone -> Some(ILVersionInfo(0us, 0us, 0us, 0us)) //If no attribute was specified in source then version is 0.0.0.0 + | _ -> Some(tcConfig.version.GetVersionInfo tcConfig.implicitIncludeDir) // write interface, xmldoc ReportTime tcConfig "Write Interface File" use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output - if tcConfig.printSignature || tcConfig.printAllSignatureFiles then InterfaceFileWriter.WriteInterfaceFile (tcGlobals, tcConfig, InfoReader(tcGlobals, tcImports.GetImportMap()), typedImplFiles) + + if tcConfig.printSignature || tcConfig.printAllSignatureFiles then + InterfaceFileWriter.WriteInterfaceFile(tcGlobals, tcConfig, InfoReader(tcGlobals, tcImports.GetImportMap()), typedImplFiles) ReportTime tcConfig "Write XML document signatures" + if tcConfig.xmlDocOutputFile.IsSome then - XmlDocWriter.ComputeXmlDocSigs (tcGlobals, generatedCcu) + XmlDocWriter.ComputeXmlDocSigs(tcGlobals, generatedCcu) ReportTime tcConfig "Write XML docs" - tcConfig.xmlDocOutputFile |> Option.iter (fun xmlFile -> + + tcConfig.xmlDocOutputFile + |> Option.iter (fun xmlFile -> let xmlFile = tcConfig.MakePathAbsolute xmlFile - XmlDocWriter.WriteXmlDocFile (tcGlobals, assemblyName, generatedCcu, xmlFile)) + XmlDocWriter.WriteXmlDocFile(tcGlobals, assemblyName, generatedCcu, xmlFile)) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, diagnosticsLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter, ilSourceDocs) - + Args( + ctok, + tcConfig, + tcImports, + frameworkTcImports, + tcGlobals, + diagnosticsLogger, + generatedCcu, + outfile, + typedImplFiles, + topAttrs, + pdbfile, + assemblyName, + assemVerFromAttrib, + signingInfo, + exiter, + ilSourceDocs + ) /// Third phase of compilation. /// - encode signature data /// - optimize /// - encode optimization data -let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, - diagnosticsLogger: DiagnosticsLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, - topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter, ilSourceDocs)) = +let main3 + (Args (ctok, + tcConfig, + tcImports, + frameworkTcImports: TcImports, + tcGlobals, + diagnosticsLogger: DiagnosticsLogger, + generatedCcu: CcuThunk, + outfile, + typedImplFiles, + topAttrs, + pdbfile, + assemblyName, + assemVerFromAttrib, + signingInfo, + exiter: Exiter, + ilSourceDocs)) + = // Encode the signature data ReportTime tcConfig "Encode Interface Data" @@ -756,21 +1043,29 @@ let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlob | Some v -> v | _ -> match frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name with - | Some ib -> ib.RawMetadata.TryGetILModuleDef().Value.MetadataVersion - | _ -> "" + | Some ib -> ib.RawMetadata.TryGetILModuleDef().Value.MetadataVersion + | _ -> "" let optimizedImpls, optDataResources = // Perform optimization use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Optimize - let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) + let optEnv0 = GetInitialOptimizationEnv(tcImports, tcGlobals) let importMap = tcImports.GetImportMap() let optimizedImpls, optimizationData, _ = - ApplyAllOptimizations - (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, - importMap, false, optEnv0, generatedCcu, typedImplFiles) + ApplyAllOptimizations( + tcConfig, + tcGlobals, + (LightweightTcValForUsingInBuildMethodCall tcGlobals), + outfile, + importMap, + false, + optEnv0, + generatedCcu, + typedImplFiles + ) AbortOnError(diagnosticsLogger, exiter) @@ -780,18 +1075,53 @@ let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlob optimizedImpls, EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, - generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, - sigDataAttributes, sigDataResources, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter, ilSourceDocs) + Args( + ctok, + tcConfig, + tcImports, + tcGlobals, + diagnosticsLogger, + generatedCcu, + outfile, + optimizedImpls, + topAttrs, + pdbfile, + assemblyName, + sigDataAttributes, + sigDataResources, + optDataResources, + assemVerFromAttrib, + signingInfo, + metadataVersion, + exiter, + ilSourceDocs + ) /// Fourth phase of compilation. /// - Static linking /// - IL code generation let main4 - (tcImportsCapture,dynamicAssemblyCreator) - (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, diagnosticsLogger, - generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, - sigDataAttributes, sigDataResources, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter, ilSourceDocs)) = + (tcImportsCapture, dynamicAssemblyCreator) + (Args (ctok, + tcConfig: TcConfig, + tcImports, + tcGlobals: TcGlobals, + diagnosticsLogger, + generatedCcu: CcuThunk, + outfile, + optimizedImpls, + topAttrs, + pdbfile, + assemblyName, + sigDataAttributes, + sigDataResources, + optDataResources, + assemVerFromAttrib, + signingInfo, + metadataVersion, + exiter: Exiter, + ilSourceDocs)) + = match tcImportsCapture with | None -> () @@ -799,50 +1129,110 @@ let main4 // Compute a static linker, it gets called later. let ilGlobals = tcGlobals.ilg + if tcConfig.standalone && generatedCcu.UsesFSharp20PlusQuotations then - error(Error(FSComp.SR.fscQuotationLiteralsStaticLinking0(), rangeStartup)) + error (Error(FSComp.SR.fscQuotationLiteralsStaticLinking0 (), rangeStartup)) - let staticLinker = StaticLink (ctok, tcConfig, tcImports, ilGlobals) + let staticLinker = StaticLink(ctok, tcConfig, tcImports, ilGlobals) ReportTime tcConfig "TAST -> IL" use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.IlxGen // Create the Abstract IL generator - let ilxGenerator = CreateIlxAssemblyGenerator (tcConfig, tcImports, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), generatedCcu) + let ilxGenerator = + CreateIlxAssemblyGenerator(tcConfig, tcImports, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), generatedCcu) - let codegenBackend = (if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend) + let codegenBackend = + (if Option.isSome dynamicAssemblyCreator then + IlReflectBackend + else + IlWriteBackend) // Generate the Abstract IL Code - let codegenResults = GenerateIlxCode (codegenBackend, Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator) + let codegenResults = + GenerateIlxCode( + codegenBackend, + Option.isSome dynamicAssemblyCreator, + false, + tcConfig, + topAttrs, + optimizedImpls, + generatedCcu.AssemblyName, + ilxGenerator + ) // Build the Abstract IL view of the final main module, prior to static linking let topAssemblyAttrs = codegenResults.topAssemblyAttrs - let topAttrs = {topAttrs with assemblyAttrs=topAssemblyAttrs} + + let topAttrs = + { topAttrs with + assemblyAttrs = topAssemblyAttrs + } + let permissionSets = codegenResults.permissionSets let secDecls = mkILSecurityDecls permissionSets let ilxMainModule = - MainModuleBuilder.CreateMainModule - (ctok, tcConfig, tcGlobals, tcImports, - pdbfile, assemblyName, outfile, topAttrs, - sigDataAttributes, sigDataResources, optDataResources, - codegenResults, assemVerFromAttrib, metadataVersion, secDecls) + MainModuleBuilder.CreateMainModule( + ctok, + tcConfig, + tcGlobals, + tcImports, + pdbfile, + assemblyName, + outfile, + topAttrs, + sigDataAttributes, + sigDataResources, + optDataResources, + codegenResults, + assemVerFromAttrib, + metadataVersion, + secDecls + ) AbortOnError(diagnosticsLogger, exiter) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter, ilSourceDocs) + Args( + ctok, + tcConfig, + tcImports, + tcGlobals, + diagnosticsLogger, + staticLinker, + outfile, + pdbfile, + ilxMainModule, + signingInfo, + exiter, + ilSourceDocs + ) /// Fifth phase of compilation. /// - static linking -let main5(Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger: DiagnosticsLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter: Exiter, ilSourceDocs)) = +let main5 + (Args (ctok, + tcConfig, + tcImports, + tcGlobals, + diagnosticsLogger: DiagnosticsLogger, + staticLinker, + outfile, + pdbfile, + ilxMainModule, + signingInfo, + exiter: Exiter, + ilSourceDocs)) + = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output // Static linking, if any let ilxMainModule = - try staticLinker ilxMainModule + try + staticLinker ilxMainModule with e -> errorRecoveryNoRange e exiter.Exit 1 @@ -850,25 +1240,37 @@ let main5(Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger: Diagnos AbortOnError(diagnosticsLogger, exiter) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, ilxMainModule, outfile, pdbfile, signingInfo, exiter, ilSourceDocs) + Args(ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, ilxMainModule, outfile, pdbfile, signingInfo, exiter, ilSourceDocs) /// Sixth phase of compilation. /// - write the binaries -let main6 dynamicAssemblyCreator (Args (ctok, tcConfig, tcImports: TcImports, tcGlobals: TcGlobals, - diagnosticsLogger: DiagnosticsLogger, ilxMainModule, outfile, pdbfile, - signingInfo, exiter: Exiter, ilSourceDocs)) = +let main6 + dynamicAssemblyCreator + (Args (ctok, + tcConfig, + tcImports: TcImports, + tcGlobals: TcGlobals, + diagnosticsLogger: DiagnosticsLogger, + ilxMainModule, + outfile, + pdbfile, + signingInfo, + exiter: Exiter, + ilSourceDocs)) + = ReportTime tcConfig "Write .NET Binary" use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output let outfile = tcConfig.MakePathAbsolute outfile - DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok - let pdbfile = pdbfile |> Option.map (tcConfig.MakePathAbsolute >> FileSystem.GetFullPathShim) + let pdbfile = + pdbfile |> Option.map (tcConfig.MakePathAbsolute >> FileSystem.GetFullPathShim) let normalizeAssemblyRefs (aref: ILAssemblyRef) = - match tcImports.TryFindDllInfo (ctok, rangeStartup, aref.Name, lookupOnly=false) with + match tcImports.TryFindDllInfo(ctok, rangeStartup, aref.Name, lookupOnly = false) with | Some dllInfo -> match dllInfo.ILScopeRef with | ILScopeRef.Assembly ref -> ref @@ -885,66 +1287,70 @@ let main6 dynamicAssemblyCreator (Args (ctok, tcConfig, tcImports: TcImports, t match tcConfig.emitMetadataAssembly with | MetadataAssemblyGeneration.ReferenceOut outputPath -> outputPath | _ -> outfile + let referenceAssemblyAttribOpt = tcGlobals.iltyp_ReferenceAssemblyAttributeOpt - |> Option.map (fun ilTy -> - mkILCustomAttribute (ilTy.TypeRef, [], [], []) - ) + |> Option.map (fun ilTy -> mkILCustomAttribute (ilTy.TypeRef, [], [], [])) + try // We want to write no PDB info. - ILBinaryWriter.WriteILBinaryFile - ({ ilg = tcGlobals.ilg - outfile = outfile - pdbfile = None - emitTailcalls = tcConfig.emitTailcalls - deterministic = tcConfig.deterministic - showTimes = tcConfig.showTimes - portablePDB = false - embeddedPDB = false - embedAllSource = tcConfig.embedAllSource - embedSourceList = tcConfig.embedSourceList - allGivenSources = ilSourceDocs - sourceLink = tcConfig.sourceLink - checksumAlgorithm = tcConfig.checksumAlgorithm - signer = GetStrongNameSigner signingInfo - dumpDebugInfo = tcConfig.dumpDebugInfo - referenceAssemblyOnly = true - referenceAssemblyAttribOpt = referenceAssemblyAttribOpt - pathMap = tcConfig.pathMap }, - ilxMainModule, - normalizeAssemblyRefs - ) + ILBinaryWriter.WriteILBinaryFile( + { + ilg = tcGlobals.ilg + outfile = outfile + pdbfile = None + emitTailcalls = tcConfig.emitTailcalls + deterministic = tcConfig.deterministic + showTimes = tcConfig.showTimes + portablePDB = false + embeddedPDB = false + embedAllSource = tcConfig.embedAllSource + embedSourceList = tcConfig.embedSourceList + allGivenSources = ilSourceDocs + sourceLink = tcConfig.sourceLink + checksumAlgorithm = tcConfig.checksumAlgorithm + signer = GetStrongNameSigner signingInfo + dumpDebugInfo = tcConfig.dumpDebugInfo + referenceAssemblyOnly = true + referenceAssemblyAttribOpt = referenceAssemblyAttribOpt + pathMap = tcConfig.pathMap + }, + ilxMainModule, + normalizeAssemblyRefs + ) with Failure msg -> - error(Error(FSComp.SR.fscProblemWritingBinary(outfile, msg), rangeCmdArgs)) + error (Error(FSComp.SR.fscProblemWritingBinary (outfile, msg), rangeCmdArgs)) match tcConfig.emitMetadataAssembly with | MetadataAssemblyGeneration.ReferenceOnly -> () | _ -> try - ILBinaryWriter.WriteILBinaryFile - ({ ilg = tcGlobals.ilg - outfile = outfile - pdbfile = pdbfile - emitTailcalls = tcConfig.emitTailcalls - deterministic = tcConfig.deterministic - showTimes = tcConfig.showTimes - portablePDB = tcConfig.portablePDB - embeddedPDB = tcConfig.embeddedPDB - embedAllSource = tcConfig.embedAllSource - embedSourceList = tcConfig.embedSourceList - allGivenSources = ilSourceDocs - sourceLink = tcConfig.sourceLink - checksumAlgorithm = tcConfig.checksumAlgorithm - signer = GetStrongNameSigner signingInfo - dumpDebugInfo = tcConfig.dumpDebugInfo - referenceAssemblyOnly = false - referenceAssemblyAttribOpt = None - pathMap = tcConfig.pathMap }, - ilxMainModule, - normalizeAssemblyRefs - ) + ILBinaryWriter.WriteILBinaryFile( + { + ilg = tcGlobals.ilg + outfile = outfile + pdbfile = pdbfile + emitTailcalls = tcConfig.emitTailcalls + deterministic = tcConfig.deterministic + showTimes = tcConfig.showTimes + portablePDB = tcConfig.portablePDB + embeddedPDB = tcConfig.embeddedPDB + embedAllSource = tcConfig.embedAllSource + embedSourceList = tcConfig.embedSourceList + allGivenSources = ilSourceDocs + sourceLink = tcConfig.sourceLink + checksumAlgorithm = tcConfig.checksumAlgorithm + signer = GetStrongNameSigner signingInfo + dumpDebugInfo = tcConfig.dumpDebugInfo + referenceAssemblyOnly = false + referenceAssemblyAttribOpt = None + pathMap = tcConfig.pathMap + }, + ilxMainModule, + normalizeAssemblyRefs + ) with Failure msg -> - error(Error(FSComp.SR.fscProblemWritingBinary(outfile, msg), rangeCmdArgs)) + error (Error(FSComp.SR.fscProblemWritingBinary (outfile, msg), rangeCmdArgs)) with e -> errorRecoveryNoRange e exiter.Exit 1 @@ -953,40 +1359,93 @@ let main6 dynamicAssemblyCreator (Args (ctok, tcConfig, tcImports: TcImports, t AbortOnError(diagnosticsLogger, exiter) // Don't copy referenced FSharp.core.dll if we are building FSharp.Core.dll - if (tcConfig.copyFSharpCore = CopyFSharpCoreFlag.Yes) && not tcConfig.compilingFSharpCore && not tcConfig.standalone then + if (tcConfig.copyFSharpCore = CopyFSharpCoreFlag.Yes) + && not tcConfig.compilingFSharpCore + && not tcConfig.standalone then CopyFSharpCore(outfile, tcConfig.referencedDLLs) ReportTime tcConfig "Exiting" /// The main (non-incremental) compilation entry point used by fsc.exe let CompileFromCommandLineArguments - (ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage, - defaultCopyFSharpCore, exiter: Exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) = + ( + ctok, + argv, + legacyReferenceResolver, + bannerAlreadyPrinted, + reduceMemoryUsage, + defaultCopyFSharpCore, + exiter: Exiter, + loggerProvider, + tcImportsCapture, + dynamicAssemblyCreator + ) = use disposables = new DisposablesTracker() let savedOut = Console.Out + use _ = { new IDisposable with member _.Dispose() = try Console.SetOut(savedOut) - with _ -> ()} - - main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage, defaultCopyFSharpCore, exiter, loggerProvider, disposables) + with _ -> + () + } + + main1 ( + ctok, + argv, + legacyReferenceResolver, + bannerAlreadyPrinted, + reduceMemoryUsage, + defaultCopyFSharpCore, + exiter, + loggerProvider, + disposables + ) |> main2 |> main3 - |> main4 (tcImportsCapture,dynamicAssemblyCreator) + |> main4 (tcImportsCapture, dynamicAssemblyCreator) |> main5 |> main6 dynamicAssemblyCreator /// An additional compilation entry point used by FSharp.Compiler.Service taking syntax trees as input let CompileFromSyntaxTrees - (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, - targetDll, targetPdb, dependencies, noframework, exiter, loggerProvider, inputs, tcImportsCapture, dynamicAssemblyCreator) = + ( + ctok, + legacyReferenceResolver, + reduceMemoryUsage, + assemblyName, + target, + targetDll, + targetPdb, + dependencies, + noframework, + exiter, + loggerProvider, + inputs, + tcImportsCapture, + dynamicAssemblyCreator + ) = use disposables = new DisposablesTracker() - main1OfAst (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, targetDll, targetPdb, - dependencies, noframework, exiter, loggerProvider, disposables, inputs) + + main1OfAst ( + ctok, + legacyReferenceResolver, + reduceMemoryUsage, + assemblyName, + target, + targetDll, + targetPdb, + dependencies, + noframework, + exiter, + loggerProvider, + disposables, + inputs + ) |> main2 |> main3 |> main4 (tcImportsCapture, dynamicAssemblyCreator) diff --git a/src/Compiler/Interactive/fsi.fs b/src/Compiler/Interactive/fsi.fs index 797f098f585..0cbade7c234 100644 --- a/src/Compiler/Interactive/fsi.fs +++ b/src/Compiler/Interactive/fsi.fs @@ -1906,7 +1906,8 @@ type internal FsiDynamicCompiler( match fsiOptions.DependencyProvider.TryFindDependencyManagerByKey(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError m, packageManagerKey) with | Null -> - errorR(Error(fsiOptions.DependencyProvider.CreatePackageManagerUnknownError(tcConfigB.compilerToolPaths, outputDir, packageManagerKey, reportError m), m)) + let err = fsiOptions.DependencyProvider.CreatePackageManagerUnknownError(tcConfigB.compilerToolPaths, outputDir, packageManagerKey, reportError m) + errorR(Error(err, m)) istate | NonNull dependencyManager -> let directive d = diff --git a/src/Compiler/Utilities/EditDistance.fs b/src/Compiler/Utilities/EditDistance.fs index 8f5a76ae152..10595b0b999 100644 --- a/src/Compiler/Utilities/EditDistance.fs +++ b/src/Compiler/Utilities/EditDistance.fs @@ -80,10 +80,7 @@ let jaro (s1: string) (s2: string) = / 3.0 // This is for cases where |s1|, |s2| or m are zero - if Double.IsNaN result then - 0.0 - else - result + if Double.IsNaN result then 0.0 else result /// Calculates the Jaro-Winkler edit distance between two strings. /// The edit distance is a metric that allows to measure the amount of similarity between two strings. diff --git a/src/Compiler/Utilities/FileSystem.fs b/src/Compiler/Utilities/FileSystem.fs index 5296f567cde..465adeac51d 100644 --- a/src/Compiler/Utilities/FileSystem.fs +++ b/src/Compiler/Utilities/FileSystem.fs @@ -127,8 +127,7 @@ type ByteArrayMemory(bytes: byte[], offset, length) = ByteArrayMemory(Array.empty, 0, 0) :> ByteMemory override _.CopyTo stream = - if length > 0 then - stream.Write(bytes, offset, length) + if length > 0 then stream.Write(bytes, offset, length) override _.Copy(srcOffset, dest, destOffset, count) = checkCount count @@ -381,12 +380,11 @@ module MemoryMappedFileExtensions = use stream = mmf.CreateViewStream(0L, length, MemoryMappedFileAccess.ReadWrite) copyTo stream Some mmf - with - | _ -> + with _ -> mmf.Dispose() None - with - | _ -> None + with _ -> + None type MemoryMappedFile with @@ -414,8 +412,7 @@ module internal FileSystemUtils = let checkSuffix (path: string) (suffix: string) = path.EndsWithOrdinalIgnoreCase(suffix) let hasExtensionWithValidate (validate: bool) (s: string) = - if validate then - (checkPathForIllegalChars s) + if validate then (checkPathForIllegalChars s) let sLen = s.Length @@ -440,8 +437,7 @@ module internal FileSystemUtils = Path.GetFileName(path) let fileNameWithoutExtensionWithValidate (validate: bool) path = - if validate then - checkPathForIllegalChars path + if validate then checkPathForIllegalChars path Path.GetFileNameWithoutExtension(path) @@ -567,8 +563,7 @@ type DefaultFileSystem() as this = let stream = new MemoryMappedStream(mmf, length) - if not stream.CanRead then - invalidOp "Cannot read file" + if not stream.CanRead then invalidOp "Cannot read file" stream :> Stream @@ -615,8 +610,8 @@ type DefaultFileSystem() as this = ifs.GetFullPathShim path else path - with - | _ -> path + with _ -> + path abstract IsInvalidPathShim: path: string -> bool @@ -886,8 +881,7 @@ type internal ByteStream = } member b.ReadByte() = - if b.pos >= b.max then - failwith "end of stream" + if b.pos >= b.max then failwith "end of stream" let res = b.bytes[b.pos] b.pos <- b.pos + 1 @@ -954,8 +948,7 @@ type internal ByteBuffer = Bytes.blit old 0 buf.bbArray 0 buf.bbCurrent - if buf.useArrayPool then - ArrayPool.Shared.Return old + if buf.useArrayPool then ArrayPool.Shared.Return old member buf.AsMemory() = buf.CheckDisposed() diff --git a/src/Compiler/Utilities/HashMultiMap.fs b/src/Compiler/Utilities/HashMultiMap.fs index b88af5d77eb..cb750676fe3 100644 --- a/src/Compiler/Utilities/HashMultiMap.fs +++ b/src/Compiler/Utilities/HashMultiMap.fs @@ -170,8 +170,7 @@ type internal HashMultiMap<'Key, 'Value>(size: int, comparer: IEqualityComparer< member s.Remove(x) = match s.TryFind x.Key with | Some v -> - if Unchecked.equals v x.Value then - s.Remove(x.Key) + if Unchecked.equals v x.Value then s.Remove(x.Key) true | _ -> false diff --git a/src/Compiler/Utilities/ImmutableArray.fs b/src/Compiler/Utilities/ImmutableArray.fs index e32ce5391b6..5311efa5e0c 100644 --- a/src/Compiler/Utilities/ImmutableArray.fs +++ b/src/Compiler/Utilities/ImmutableArray.fs @@ -18,8 +18,7 @@ module ImmutableArray = | 0 -> ImmutableArray.Empty | 1 -> ImmutableArray.Create(f 0) | n -> - if n < 0 then - invalidArg "n" "Below zero." + if n < 0 then invalidArg "n" "Below zero." let builder = ImmutableArray.CreateBuilder(n) @@ -144,12 +143,9 @@ module ImmutableArray = let tryFind predicate (arr: ImmutableArray<'T>) = let rec loop i = - if i >= arr.Length then - None - else if predicate arr[i] then - Some arr[i] - else - loop (i + 1) + if i >= arr.Length then None + else if predicate arr[i] then Some arr[i] + else loop (i + 1) loop 0 @@ -184,8 +180,7 @@ module ImmutableArray = let builder = ImmutableArray.CreateBuilder(arr.Length) for i = 0 to arr.Length - 1 do - if predicate arr[i] then - builder.Add(arr[i]) + if predicate arr[i] then builder.Add(arr[i]) builder.Capacity <- builder.Count builder.MoveToImmutable() @@ -204,8 +199,7 @@ module ImmutableArray = for i = 0 to arr.Length - 1 do let result = chooser arr[i] - if result.IsSome then - builder.Add(result.Value) + if result.IsSome then builder.Add(result.Value) builder.Capacity <- builder.Count builder.MoveToImmutable() diff --git a/src/Compiler/Utilities/InternalCollections.fs b/src/Compiler/Utilities/InternalCollections.fs index 8ef878530d0..96aaf9b684f 100755 --- a/src/Compiler/Utilities/InternalCollections.fs +++ b/src/Compiler/Utilities/InternalCollections.fs @@ -142,11 +142,7 @@ type internal AgedLookup<'Token, 'Key, 'Value when 'Value: not struct>(keepStron member al.Put(tok, key, value) = let data = FilterAndHold(tok) - let data = - if Exists(data, key) then - RemoveImpl(data, key) - else - data + let data = if Exists(data, key) then RemoveImpl(data, key) else data let data = Add(data, key, value) AssignWithStrength(tok, data) // This will remove extras @@ -201,11 +197,7 @@ type internal MruCache<'Token, 'Key, 'Value when 'Value: not struct> member bc.TryGetAny(tok, key) = match cache.TryPeekKeyValue(tok, key) with - | Some (similarKey, value) -> - if areSame (similarKey, key) then - Some(value) - else - None + | Some (similarKey, value) -> if areSame (similarKey, key) then Some(value) else None | None -> None member bc.TryGet(tok, key) = @@ -224,11 +216,7 @@ type internal MruCache<'Token, 'Key, 'Value when 'Value: not struct> member bc.TryGetSimilar(tok, key) = match cache.TryGetKeyValue(tok, key) with - | Some (_, value) -> - if isStillValid (key, value) then - Some value - else - None + | Some (_, value) -> if isStillValid (key, value) then Some value else None | None -> None member bc.Set(tok, key: 'Key, value: 'Value) = cache.Put(tok, key, value) diff --git a/src/Compiler/Utilities/QueueList.fs b/src/Compiler/Utilities/QueueList.fs index 2cab0fe0b70..2c6852f8fc7 100644 --- a/src/Compiler/Utilities/QueueList.fs +++ b/src/Compiler/Utilities/QueueList.fs @@ -27,10 +27,7 @@ type internal QueueList<'T>(firstElementsIn: 'T list, lastElementsRevIn: 'T list // Compute the last elements on demand. let lastElements () = - if push then - [] - else - List.rev lastElementsRev + if push then [] else List.rev lastElementsRev static let empty = QueueList<'T>([], [], 0) diff --git a/src/Compiler/Utilities/ResizeArray.fs b/src/Compiler/Utilities/ResizeArray.fs index a54521525f5..e96c775f972 100644 --- a/src/Compiler/Utilities/ResizeArray.fs +++ b/src/Compiler/Utilities/ResizeArray.fs @@ -26,8 +26,7 @@ module internal ResizeArray = if start2 < 0 then invalidArg "start2" "index must be positive" - if len < 0 then - invalidArg "len" "length must be positive" + if len < 0 then invalidArg "len" "length must be positive" if start1 + len > length arr1 then invalidArg "start1" "(start1+len) out of range" @@ -53,8 +52,7 @@ module internal ResizeArray = if start < 0 then invalidArg "start" "index must be positive" - if len < 0 then - invalidArg "len" "length must be positive" + if len < 0 then invalidArg "len" "length must be positive" if start + len > length arr then invalidArg "len" "length must be positive" @@ -65,8 +63,7 @@ module internal ResizeArray = if start < 0 then invalidArg "start" "index must be positive" - if len < 0 then - invalidArg "len" "length must be positive" + if len < 0 then invalidArg "len" "length must be positive" if start + len > length arr then invalidArg "len" "length must be positive" diff --git a/src/Compiler/Utilities/TaggedCollections.fs b/src/Compiler/Utilities/TaggedCollections.fs index 00e0ceb8d1d..c36cf0afb4f 100644 --- a/src/Compiler/Utilities/TaggedCollections.fs +++ b/src/Compiler/Utilities/TaggedCollections.fs @@ -106,12 +106,9 @@ module SetTree = // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated let c = comparer.Compare(k, t.Key) - if c < 0 then - SetTreeNode(k, empty, t, 2) :> SetTree<'T> - elif c = 0 then - t - else - SetTreeNode(k, t, empty, 2) :> SetTree<'T> + if c < 0 then SetTreeNode(k, empty, t, 2) :> SetTree<'T> + elif c = 0 then t + else SetTreeNode(k, t, empty, 2) :> SetTree<'T> let rec balance comparer (t1: SetTree<'T>) k (t2: SetTree<'T>) = // Given t1 < k < t2 where t1 and t2 are "balanced", @@ -211,12 +208,9 @@ module SetTree = match t with | :? SetTreeNode<'T> as tn -> - if c < 0 then - contains comparer k tn.Left - elif c = 0 then - true - else - contains comparer k tn.Right + if c < 0 then contains comparer k tn.Left + elif c = 0 then true + else contains comparer k tn.Right | _ -> (c = 0) let rec iter f (t: SetTree<'T>) = @@ -266,18 +260,10 @@ module SetTree = else match t with | :? SetTreeNode<'T> as tn -> - let acc = - if f tn.Key then - add comparer tn.Key acc - else - acc + let acc = if f tn.Key then add comparer tn.Key acc else acc filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) - | _ -> - if f t.Key then - add comparer t.Key acc - else - acc + | _ -> if f t.Key then add comparer t.Key acc else acc let filter comparer f s = filterAux comparer f s empty @@ -495,10 +481,7 @@ module SetTree = | _, [] -> 1 | x1 :: t1, x2 :: t2 -> if isEmpty x1 then - if isEmpty x2 then - compareStacks comparer t1 t2 - else - cont () + if isEmpty x2 then compareStacks comparer t1 t2 else cont () elif isEmpty x2 then cont () else @@ -540,10 +523,7 @@ module SetTree = | _ -> let c = comparer.Compare(x1.Key, x2.Key) - if c <> 0 then - c - else - compareStacks comparer t1 t2 + if c <> 0 then c else compareStacks comparer t1 t2 let compare comparer (t1: SetTree<'T>) (t2: SetTree<'T>) = if isEmpty t1 then @@ -648,20 +628,14 @@ type internal Set<'T, 'ComparerTag> when 'ComparerTag :> IComparer<'T>(comparer: SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a static member Union(a: Set<'T, 'ComparerTag>, b: Set<'T, 'ComparerTag>) : Set<'T, 'ComparerTag> = - if SetTree.isEmpty b.Tree then - a (* A U 0 = A *) - else if SetTree.isEmpty a.Tree then - b (* 0 U B = B *) - else - SetTree.union a.Comparer a.Tree b.Tree |> refresh a + if SetTree.isEmpty b.Tree then a (* A U 0 = A *) + else if SetTree.isEmpty a.Tree then b (* 0 U B = B *) + else SetTree.union a.Comparer a.Tree b.Tree |> refresh a static member Difference(a: Set<'T, 'ComparerTag>, b: Set<'T, 'ComparerTag>) : Set<'T, 'ComparerTag> = - if SetTree.isEmpty a.Tree then - a (* 0 - B = 0 *) - else if SetTree.isEmpty b.Tree then - a (* A - 0 = A *) - else - SetTree.diff a.Comparer a.Tree b.Tree |> refresh a + if SetTree.isEmpty a.Tree then a (* 0 - B = 0 *) + else if SetTree.isEmpty b.Tree then a (* A - 0 = A *) + else SetTree.diff a.Comparer a.Tree b.Tree |> refresh a static member Equality(a: Set<'T, 'ComparerTag>, b: Set<'T, 'ComparerTag>) = (SetTree.compare a.Comparer a.Tree b.Tree = 0) @@ -852,18 +826,12 @@ module MapTree = let find (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> - if tryGetValue comparer k &v m then - v - else - indexNotFound () + if tryGetValue comparer k &v m then v else indexNotFound () let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> - if tryGetValue comparer k &v m then - Some v - else - None + if tryGetValue comparer k &v m then Some v else None let partition1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v (acc1, acc2) = if f.Invoke(k, v) then @@ -886,10 +854,7 @@ module MapTree = partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) let filter1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v acc = - if f.Invoke(k, v) then - add comparer k v acc - else - acc + if f.Invoke(k, v) then add comparer k v acc else acc let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then @@ -1061,11 +1026,7 @@ module MapTree = let cLoKey = comparer.Compare(lo, mn.Key) let cKeyHi = comparer.Compare(mn.Key, hi) - let x = - if cLoKey < 0 then - foldFromTo f mn.Left x - else - x + let x = if cLoKey < 0 then foldFromTo f mn.Left x else x let x = if cLoKey <= 0 && cKeyHi <= 0 then @@ -1073,11 +1034,7 @@ module MapTree = else x - let x = - if cKeyHi < 0 then - foldFromTo f mn.Right x - else - x + let x = if cKeyHi < 0 then foldFromTo f mn.Right x else x x | _ -> @@ -1092,10 +1049,7 @@ module MapTree = x - if comparer.Compare(lo, hi) = 1 then - x - else - foldFromTo f m x + if comparer.Compare(lo, hi) = 1 then x else foldFromTo f m x let foldSection (comparer: IComparer<'Key>) lo hi f m x = foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index f9cfe5ce0e8..b5e0a2d5218 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -71,8 +71,7 @@ module internal PervasiveAutoOpens = // "How can I detect if am running in Mono?" section try Type.GetType "Mono.Runtime" <> null - with - | _ -> + with _ -> // Must be robust in the case that someone else has installed a handler into System.AppDomain.OnTypeResolveEvent // that is not reliable. // This is related to bug 5506--the issue is actually a bug in VSTypeResolutionService.EnsurePopulated which is @@ -197,8 +196,7 @@ module Array = let mutable i = 0 while eq && i < len do - if not (inp[i] === res[i]) then - eq <- false + if not (inp[i] === res[i]) then eq <- false i <- i + 1 @@ -373,8 +371,8 @@ module Option = let attempt (f: unit -> 'T) = try Some(f ()) - with - | _ -> None + with _ -> + None module List = @@ -404,11 +402,7 @@ module List = let rec findi n f l = match l with | [] -> None - | h :: t -> - if f h then - Some(h, n) - else - findi (n + 1) f t + | h :: t -> if f h then Some(h, n) else findi (n + 1) f t let splitChoose select l = let rec ch acc1 acc2 l = @@ -438,10 +432,7 @@ module List = let h2a = f h1a let h2b = f h1b - if h1a === h2a && h1b === h2b then - inp - else - [ h2a; h2b ] + if h1a === h2a && h1b === h2b then inp else [ h2a; h2b ] | [ h1a; h1b; h1c ] -> let h2a = f h1a let h2b = f h1b @@ -466,15 +457,16 @@ module List = loop [] l + let tryFrontAndBack l = + match l with + | [] -> None + | _ -> Some(frontAndBack l) + let tryRemove f inp = let rec loop acc l = match l with | [] -> None - | h :: t -> - if f h then - Some(h, List.rev acc @ t) - else - loop (h :: acc) t + | h :: t -> if f h then Some(h, List.rev acc @ t) else loop (h :: acc) t loop [] inp @@ -499,11 +491,7 @@ module List = let rec loop acc l = match l with | [] -> List.rev acc, [] - | x :: xs -> - if p x then - List.rev acc, l - else - loop (x :: acc) xs + | x :: xs -> if p x then List.rev acc, l else loop (x :: acc) xs loop [] l @@ -544,11 +532,7 @@ module List = let rec mn i = function | [] -> [] - | x :: xs -> - if i = n then - f x :: xs - else - x :: mn (i + 1) xs + | x :: xs -> if i = n then f x :: xs else x :: mn (i + 1) xs mn 0 xs @@ -746,20 +730,14 @@ module String = let split options (separator: string[]) (value: string) = value.Split(separator, options) let (|StartsWith|_|) pattern value = - if String.IsNullOrWhiteSpace value then - None - elif value.StartsWithOrdinal pattern then - Some() - else - None + if String.IsNullOrWhiteSpace value then None + elif value.StartsWithOrdinal pattern then Some() + else None let (|Contains|_|) pattern value = - if String.IsNullOrWhiteSpace value then - None - elif value.Contains pattern then - Some() - else - None + if String.IsNullOrWhiteSpace value then None + elif value.Contains pattern then Some() + else None let getLines (str: string) = use reader = new StringReader(str) @@ -991,8 +969,8 @@ module Cancellable = match f ct with | ValueOrCancelled.Value res -> ValueOrCancelled.Value(Choice1Of2 res) | ValueOrCancelled.Cancelled exn -> ValueOrCancelled.Cancelled exn - with - | err -> ValueOrCancelled.Value(Choice2Of2 err)) + with err -> + ValueOrCancelled.Value(Choice2Of2 err)) /// Implement try/finally for a cancellable computation let inline tryFinally comp compensation = @@ -1162,8 +1140,7 @@ type LazyWithContext<'T, 'Ctxt> = x.value <- res x.funcOrException <- null res - with - | exn -> + with exn -> x.funcOrException <- box (LazyWithContextFailure(exn)) reraise () | _ -> failwith "unreachable" @@ -1281,8 +1258,8 @@ module NameMap = (fun n x2 acc -> try f n (Map.find n m1) x2 acc - with - | :? KeyNotFoundException -> errf n x2) + with :? KeyNotFoundException -> + errf n x2) m2 acc diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index 6f7a0591bdc..f2518c2cfb3 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -154,6 +154,8 @@ module internal List = val frontAndBack: l: 'a list -> 'a list * 'a + val tryFrontAndBack: l: 'a list -> ('a list * 'a) option + val tryRemove: f: ('a -> bool) -> inp: 'a list -> ('a * 'a list) option val zip4: l1: 'a list -> l2: 'b list -> l3: 'c list -> l4: 'd list -> ('a * 'b * 'c * 'd) list @@ -531,18 +533,21 @@ module internal NameMap = val layer: m1: NameMap<'T> -> m2: Map -> Map /// Not a very useful function - only called in one place - should be changed - val layerAdditive: addf: ('a list -> 'b -> 'a list) -> m1: Map<'c, 'b> -> m2: Map<'c, 'a list> -> Map<'c, 'a list> - when 'c: comparison + val layerAdditive: + addf: ('a list -> 'b -> 'a list) -> m1: Map<'c, 'b> -> m2: Map<'c, 'a list> -> Map<'c, 'a list> + when 'c: comparison /// Union entries by identical key, using the provided function to union sets of values val union: unionf: (seq<'a> -> 'b) -> ms: seq> -> Map /// For every entry in m2 find an entry in m1 and fold - val subfold2: errf: ('a -> 'b -> 'c) -> f: ('a -> 'd -> 'b -> 'c -> 'c) -> m1: Map<'a, 'd> -> m2: Map<'a, 'b> -> acc: 'c -> 'c - when 'a: comparison + val subfold2: + errf: ('a -> 'b -> 'c) -> f: ('a -> 'd -> 'b -> 'c -> 'c) -> m1: Map<'a, 'd> -> m2: Map<'a, 'b> -> acc: 'c -> 'c + when 'a: comparison - val suball2: errf: ('a -> 'b -> bool) -> p: ('c -> 'b -> bool) -> m1: Map<'a, 'c> -> m2: Map<'a, 'b> -> bool - when 'a: comparison + val suball2: + errf: ('a -> 'b -> bool) -> p: ('c -> 'b -> bool) -> m1: Map<'a, 'c> -> m2: Map<'a, 'b> -> bool + when 'a: comparison val mapFold: f: ('a -> string -> 'T -> 'b * 'a) -> s: 'a -> l: NameMap<'T> -> Map * 'a diff --git a/src/Compiler/Utilities/range.fs b/src/Compiler/Utilities/range.fs index b8c98f92ada..035a5de80f4 100755 --- a/src/Compiler/Utilities/range.fs +++ b/src/Compiler/Utilities/range.fs @@ -363,8 +363,8 @@ type Range(code1: int64, code2: int64) = |> Seq.take (m.EndLine - m.StartLine + 1) |> String.concat "\n" |> fun s -> s.Substring(startCol + 1, s.LastIndexOf("\n", StringComparison.Ordinal) + 1 - startCol + endCol) - with - | e -> e.ToString() + with e -> + e.ToString() member m.ToShortString() = sprintf "(%d,%d--%d,%d)" m.StartLine m.StartColumn m.EndLine m.EndColumn @@ -542,5 +542,5 @@ module Range = match nonEmptyLine with | Some (i, s) -> mkRange file (mkPos (i + 1) 0) (mkPos (i + 1) s.Length) | None -> mkRange file (mkPos 1 0) (mkPos 1 80) - with - | _ -> mkRange file (mkPos 1 0) (mkPos 1 80) + with _ -> + mkRange file (mkPos 1 0) (mkPos 1 80) diff --git a/src/Compiler/Utilities/rational.fs b/src/Compiler/Utilities/rational.fs index 563c49cb60c..13aca52dd62 100644 --- a/src/Compiler/Utilities/rational.fs +++ b/src/Compiler/Utilities/rational.fs @@ -12,10 +12,7 @@ type Rational = } let rec gcd a (b: BigInteger) = - if b = BigInteger.Zero then - a - else - gcd b (a % b) + if b = BigInteger.Zero then a else gcd b (a % b) let lcm a b = (a * b) / (gcd a b) @@ -27,11 +24,7 @@ let mkRational p q = let g = gcd q p in p / g, q / g - let p, q = - if q > BigInteger.Zero then - p, q - else - -p, -q + let p, q = if q > BigInteger.Zero then p, q else -p, -q in @@ -73,9 +66,6 @@ let GetNumerator p = int p.numerator let GetDenominator p = int p.denominator let SignRational p = - if p.numerator < BigInteger.Zero then - -1 - else if p.numerator > BigInteger.Zero then - 1 - else - 0 + if p.numerator < BigInteger.Zero then -1 + else if p.numerator > BigInteger.Zero then 1 + else 0 diff --git a/src/Compiler/Utilities/sformat.fs b/src/Compiler/Utilities/sformat.fs index d0e0d6fe5ef..e9ff2aecd26 100644 --- a/src/Compiler/Utilities/sformat.fs +++ b/src/Compiler/Utilities/sformat.fs @@ -589,14 +589,14 @@ module Display = ty.GetMethod("ToString", BindingFlags.Public ||| BindingFlags.Instance, null, [||], null) methInfo.DeclaringType = typeof - with - | _e -> false + with _e -> + false let catchExn f = try Choice1Of2(f ()) - with - | e -> Choice2Of2 e + with e -> + Choice2Of2 e // An implementation of break stack. // Uses mutable state, relying on linear threading of the state. @@ -630,16 +630,11 @@ module Display = Breaks(next + 1, outer, stack) let popBreak (Breaks (next, outer, stack)) = - if next = 0 then - raise (Failure "popBreak: underflow") + if next = 0 then raise (Failure "popBreak: underflow") let topBroke = stack[next - 1] < 0 - let outer = - if outer = next then - outer - 1 - else - outer // if all broken, unwind + let outer = if outer = next then outer - 1 else outer // if all broken, unwind let next = next - 1 Breaks(next, outer, stack), topBroke @@ -977,10 +972,7 @@ module Display = let exceededPrintSize () = size <= 0 let countNodes n = - if size > 0 then - size <- size - n - else - () // no need to keep decrementing (and avoid wrap around) + if size > 0 then size <- size - n else () // no need to keep decrementing (and avoid wrap around) let stopShort _ = exceededPrintSize () // for unfoldL @@ -1039,8 +1031,7 @@ module Display = path.Remove(x) |> ignore res - with - | e -> + with e -> countNodes 1 wordL (tagText ("Error: " + e.Message)) @@ -1157,8 +1148,8 @@ module Display = ) ) ) - with - | _ -> None + with _ -> + None // Seed with an empty layout with a space to the left for formatting purposes buildObjMessageL txt [ leftL (tagText "") ] @@ -1296,10 +1287,7 @@ module Display = |> makeListL let project1 x = - if x >= (b1 + n1) then - None - else - Some(x, x + 1) + if x >= (b1 + n1) then None else Some(x, x + 1) let rowsL = boundedUnfoldL rowL project1 stopShort b1 opts.PrintLength @@ -1341,11 +1329,7 @@ module Display = let itemLs = boundedUnfoldL possibleKeyValueL - (fun () -> - if it.MoveNext() then - Some(it.Current, ()) - else - None) + (fun () -> if it.MoveNext() then Some(it.Current, ()) else None) stopShort () (1 + opts.PrintLength / 12) @@ -1463,12 +1447,11 @@ module Display = tagProperty m.Name), (try Some(nestedObjL nDepth Precedence.BracketIfTuple ((getProperty ty obj m.Name), ty)) - with - | _ -> + with _ -> try Some(nestedObjL nDepth Precedence.BracketIfTuple ((getField obj (m :?> FieldInfo)), ty)) - with - | _ -> None))) + with _ -> + None))) |> Array.toList |> makePropertiesL) @@ -1594,8 +1577,7 @@ module Display = match text with | null -> "" | _ -> text - with - | e -> + with e -> // If a .ToString() call throws an exception, catch it and use the message as the result. // This may be informative, e.g. division by zero etc... "" diff --git a/src/FSharp.Build/CreateFSharpManifestResourceName.fs b/src/FSharp.Build/CreateFSharpManifestResourceName.fs index 175a76d2030..9c86fb7fb7d 100644 --- a/src/FSharp.Build/CreateFSharpManifestResourceName.fs +++ b/src/FSharp.Build/CreateFSharpManifestResourceName.fs @@ -35,8 +35,8 @@ type CreateFSharpManifestResourceName public () = let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null - with - | e -> false + with e -> + false let fileName = if diff --git a/src/FSharp.Build/FSharpEmbedResXSource.fs b/src/FSharp.Build/FSharpEmbedResXSource.fs index 4318ff75e46..59a3930059d 100644 --- a/src/FSharp.Build/FSharpEmbedResXSource.fs +++ b/src/FSharp.Build/FSharpEmbedResXSource.fs @@ -118,8 +118,7 @@ module internal {1} = File.WriteAllText(sourcePath, body.ToString()) printMessage <| sprintf "Done: %s" sourcePath Some(sourcePath) - with - | e -> + with e -> printf "An exception occurred when processing '%s'\n%s" resx (e.ToString()) None diff --git a/src/FSharp.Build/FSharpEmbedResourceText.fs b/src/FSharp.Build/FSharpEmbedResourceText.fs index ede5581c02e..77002aa4f54 100644 --- a/src/FSharp.Build/FSharpEmbedResourceText.fs +++ b/src/FSharp.Build/FSharpEmbedResourceText.fs @@ -236,8 +236,7 @@ type FSharpEmbedResourceText() = let str = try System.String.Format(Unquote(txt.Substring i)) // Format turns e.g '\n' into that char, but also requires that we 'escape' curlies in the original .txt file, e.g. "{{" - with - | e -> + with e -> Err( fileName, lineNum, @@ -551,8 +550,7 @@ open Printf xd.Save outXmlStream printMessage (sprintf "Done %s" outFileName) Some(fileName, outFileName, outXmlFileName) - with - | e -> + with e -> PrintErr(fileName, 0, sprintf "An exception occurred when processing '%s'\n%s" fileName (e.ToString())) None diff --git a/src/FSharp.Build/Fsc.fs b/src/FSharp.Build/Fsc.fs index 436f481d7c5..d7e0d8c52e4 100644 --- a/src/FSharp.Build/Fsc.fs +++ b/src/FSharp.Build/Fsc.fs @@ -68,8 +68,8 @@ type public Fsc() as this = let locationOfThisDll = try Some(Path.GetDirectoryName(typeof.Assembly.Location)) - with - | _ -> None + with _ -> + None match FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(locationOfThisDll) with | Some s -> s @@ -677,8 +677,7 @@ type public Fsc() as this = try invokeCompiler baseCallDelegate - with - | e -> + with e -> Debug.Fail( "HostObject received by Fsc task did not have a Compile method or the compile method threw an exception. " + (e.ToString()) diff --git a/src/FSharp.Build/Fsi.fs b/src/FSharp.Build/Fsi.fs index 634f92023bd..76dec9c78e4 100644 --- a/src/FSharp.Build/Fsi.fs +++ b/src/FSharp.Build/Fsi.fs @@ -51,8 +51,8 @@ type public Fsi() as this = let locationOfThisDll = try Some(Path.GetDirectoryName(typeof.Assembly.Location)) - with - | _ -> None + with _ -> + None match FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(locationOfThisDll) with | Some s -> s @@ -361,8 +361,7 @@ type public Fsi() as this = try invokeCompiler baseCallDelegate - with - | e -> + with e -> Debug.Assert( false, "HostObject received by Fsi task did not have a Compile method or the compile method threw an exception. " diff --git a/src/FSharp.Build/SubstituteText.fs b/src/FSharp.Build/SubstituteText.fs index c4be2300c0f..0f036da0a86 100644 --- a/src/FSharp.Build/SubstituteText.fs +++ b/src/FSharp.Build/SubstituteText.fs @@ -87,8 +87,8 @@ type SubstituteText() = Directory.CreateDirectory(directory) |> ignore File.WriteAllText(targetPath, contents) - with - | _ -> () + with _ -> + () copiedFiles.Add(item) diff --git a/src/FSharp.Build/WriteCodeFragment.fs b/src/FSharp.Build/WriteCodeFragment.fs index 7cc80eeafc4..ab390ae4a59 100644 --- a/src/FSharp.Build/WriteCodeFragment.fs +++ b/src/FSharp.Build/WriteCodeFragment.fs @@ -166,7 +166,6 @@ type WriteCodeFragment() = _outputFile <- outputFileItem true - with - | e -> + with e -> printf "Error writing code fragment: %s" (e.ToString()) false diff --git a/src/FSharp.Compiler.Interactive.Settings/fsiaux.fs b/src/FSharp.Compiler.Interactive.Settings/fsiaux.fs index bf70d1535b3..89362feb114 100644 --- a/src/FSharp.Compiler.Interactive.Settings/fsiaux.fs +++ b/src/FSharp.Compiler.Interactive.Settings/fsiaux.fs @@ -52,8 +52,8 @@ type internal SimpleEventLoop() = result <- try Some(f ()) - with - | _ -> None) + with _ -> + None) setSignal doneSignal run () diff --git a/src/FSharp.Core/.editorconfig b/src/FSharp.Core/.editorconfig new file mode 100644 index 00000000000..744ee2347a9 --- /dev/null +++ b/src/FSharp.Core/.editorconfig @@ -0,0 +1,6 @@ +# FSharp.Core uses more "conservative" settings - more lines etc. + +[*.fs] +max_line_length=120 +fsharp_max_function_binding_width=1 +fsharp_max_if_then_else_short_width=40 \ No newline at end of file diff --git a/src/FSharp.Core/MutableTuple.fs b/src/FSharp.Core/MutableTuple.fs index 79e7d5c73ed..a9292f1c48b 100644 --- a/src/FSharp.Core/MutableTuple.fs +++ b/src/FSharp.Core/MutableTuple.fs @@ -7,170 +7,210 @@ open Microsoft.FSharp.Core // ---------------------------------------------------------------------------- // Mutable Tuples - used when translating queries that use F# tuples -// and records. We replace tuples/records with anonymous types which +// and records. We replace tuples/records with anonymous types which // are handled correctly by LINQ to SQL/Entities and other providers. // // NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE // -// The terminology "mutable tuple" is now incorrect in this code - +// The terminology "mutable tuple" is now incorrect in this code - // "immutable anonymous tuple-like types" are used instead. The key thing in this // code is that the anonymous types used conform to the shape and style // expected by LINQ providers, and we pass the correspondence between constructor // arguments and properties to the magic "members" argument of the Expression.New // constructor in Linq.fs. // -// This terminology mistake also runs all the way through Query.fs. +// This terminology mistake also runs all the way through Query.fs. // ---------------------------------------------------------------------------- /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - new (Item1) = { item1 = Item1 } + new(Item1) = { item1 = Item1 } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - new (Item1, Item2) = { item1 = Item1; item2 = Item2 } + new(Item1, Item2) = { item1 = Item1; item2 = Item2 } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2, 'T3> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - val private item3 : 'T3 + val private item3: 'T3 member x.Item3 = x.item3 - new (Item1, Item2, Item3) = { item1 = Item1; item2 = Item2; item3 = Item3 } - + new(Item1, Item2, Item3) = + { + item1 = Item1 + item2 = Item2 + item3 = Item3 + } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2, 'T3, 'T4> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - val private item3 : 'T3 + val private item3: 'T3 member x.Item3 = x.item3 - val private item4 : 'T4 + val private item4: 'T4 member x.Item4 = x.item4 - new (Item1, Item2, Item3, Item4) = { item1 = Item1; item2 = Item2; item3 = Item3; item4 = Item4 } - - + new(Item1, Item2, Item3, Item4) = + { + item1 = Item1 + item2 = Item2 + item3 = Item3 + item4 = Item4 + } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2, 'T3, 'T4, 'T5> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - val private item3 : 'T3 + val private item3: 'T3 member x.Item3 = x.item3 - val private item4 : 'T4 + val private item4: 'T4 member x.Item4 = x.item4 - val private item5 : 'T5 + val private item5: 'T5 member x.Item5 = x.item5 - new (Item1, Item2, Item3, Item4, Item5) = { item1 = Item1; item2 = Item2; item3 = Item3; item4 = Item4 ; item5 = Item5 } - + new(Item1, Item2, Item3, Item4, Item5) = + { + item1 = Item1 + item2 = Item2 + item3 = Item3 + item4 = Item4 + item5 = Item5 + } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2, 'T3, 'T4, 'T5, 'T6> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - val private item3 : 'T3 + val private item3: 'T3 member x.Item3 = x.item3 - val private item4 : 'T4 + val private item4: 'T4 member x.Item4 = x.item4 - val private item5 : 'T5 + val private item5: 'T5 member x.Item5 = x.item5 - val private item6 : 'T6 + val private item6: 'T6 member x.Item6 = x.item6 - new (Item1, Item2, Item3, Item4, Item5, Item6) = { item1 = Item1; item2 = Item2; item3 = Item3; item4 = Item4 ; item5 = Item5 ; item6 = Item6 } - + new(Item1, Item2, Item3, Item4, Item5, Item6) = + { + item1 = Item1 + item2 = Item2 + item3 = Item3 + item4 = Item4 + item5 = Item5 + item6 = Item6 + } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2, 'T3, 'T4, 'T5, 'T6, 'T7> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - val private item3 : 'T3 + val private item3: 'T3 member x.Item3 = x.item3 - val private item4 : 'T4 + val private item4: 'T4 member x.Item4 = x.item4 - val private item5 : 'T5 + val private item5: 'T5 member x.Item5 = x.item5 - val private item6 : 'T6 + val private item6: 'T6 member x.Item6 = x.item6 - val private item7 : 'T7 + val private item7: 'T7 member x.Item7 = x.item7 - new (Item1, Item2, Item3, Item4, Item5, Item6, Item7) = { item1 = Item1; item2 = Item2; item3 = Item3; item4 = Item4 ; item5 = Item5 ; item6 = Item6 ; item7 = Item7 } + new(Item1, Item2, Item3, Item4, Item5, Item6, Item7) = + { + item1 = Item1 + item2 = Item2 + item3 = Item3 + item4 = Item4 + item5 = Item5 + item6 = Item6 + item7 = Item7 + } /// This type shouldn't be used directly from user code. /// type AnonymousObject<'T1, 'T2, 'T3, 'T4, 'T5, 'T6, 'T7, 'T8> = - val private item1 : 'T1 - member x.Item1 = x.item1 + val private item1: 'T1 + member x.Item1 = x.item1 - val private item2 : 'T2 + val private item2: 'T2 member x.Item2 = x.item2 - val private item3 : 'T3 + val private item3: 'T3 member x.Item3 = x.item3 - val private item4 : 'T4 + val private item4: 'T4 member x.Item4 = x.item4 - val private item5 : 'T5 + val private item5: 'T5 member x.Item5 = x.item5 - val private item6 : 'T6 + val private item6: 'T6 member x.Item6 = x.item6 - val private item7 : 'T7 + val private item7: 'T7 member x.Item7 = x.item7 - val private item8 : 'T8 + val private item8: 'T8 member x.Item8 = x.item8 - new (Item1, Item2, Item3, Item4, Item5, Item6, Item7, Item8) = { item1 = Item1; item2 = Item2; item3 = Item3; item4 = Item4 ; item5 = Item5 ; item6 = Item6 ; item7 = Item7; item8 = Item8 } + new(Item1, Item2, Item3, Item4, Item5, Item6, Item7, Item8) = + { + item1 = Item1 + item2 = Item2 + item3 = Item3 + item4 = Item4 + item5 = Item5 + item6 = Item6 + item7 = Item7 + item8 = Item8 + } diff --git a/src/FSharp.Core/Nullable.fs b/src/FSharp.Core/Nullable.fs index 02d58b2a8ac..354ce7bca75 100644 --- a/src/FSharp.Core/Nullable.fs +++ b/src/FSharp.Core/Nullable.fs @@ -9,134 +9,297 @@ open Microsoft.FSharp.Core open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators module NullableOperators = - let (?>=) (x : Nullable<'T>) (y: 'T) = x.HasValue && x.Value >= y + let (?>=) (x: Nullable<'T>) (y: 'T) = + x.HasValue && x.Value >= y - let (?>) (x : Nullable<'T>) (y: 'T) = x.HasValue && x.Value > y + let (?>) (x: Nullable<'T>) (y: 'T) = + x.HasValue && x.Value > y - let (?<=) (x : Nullable<'T>) (y: 'T) = x.HasValue && x.Value <= y + let (?<=) (x: Nullable<'T>) (y: 'T) = + x.HasValue && x.Value <= y - let (?<) (x : Nullable<'T>) (y: 'T) = x.HasValue && x.Value < y + let (?<) (x: Nullable<'T>) (y: 'T) = + x.HasValue && x.Value < y + + let (?=) (x: Nullable<'T>) (y: 'T) = + x.HasValue && x.Value = y - let (?=) (x : Nullable<'T>) (y: 'T) = x.HasValue && x.Value = y - - let (?<>) (x : Nullable<'T>) (y: 'T) = not (x ?= y) - - let (>=?) (x : 'T) (y: Nullable<'T>) = y.HasValue && x >= y.Value - - let (>?) (x : 'T) (y: Nullable<'T>) = y.HasValue && x > y.Value - - let (<=?) (x : 'T) (y: Nullable<'T>) = y.HasValue && x <= y.Value - - let () = y.HasValue && x < y.Value - - let (=?) (x : 'T) (y: Nullable<'T>) = y.HasValue && x = y.Value - - let (<>?) (x : 'T) (y: Nullable<'T>) = not (x =? y) - - let (?>=?) (x : Nullable<'T>) (y: Nullable<'T>) = (x.HasValue && y.HasValue && x.Value >= y.Value) - - let (?>?) (x : Nullable<'T>) (y: Nullable<'T>) = (x.HasValue && y.HasValue && x.Value > y.Value) - - let (?<=?) (x : Nullable<'T>) (y: Nullable<'T>) = (x.HasValue && y.HasValue && x.Value <= y.Value) - - let (?) (y: Nullable<'T>) = (x.HasValue && y.HasValue && x.Value < y.Value) - - let (?=?) (x : Nullable<'T>) (y: Nullable<'T>) = (not x.HasValue && not y.HasValue) || (x.HasValue && y.HasValue && x.Value = y.Value) - - let (?<>?) (x : Nullable<'T>) (y: Nullable<'T>) = not (x ?=? y) - - let inline (?+) (x : Nullable<_>) y = if x.HasValue then Nullable(x.Value + y) else Nullable() - - let inline (+?) x (y: Nullable<_>) = if y.HasValue then Nullable(x + y.Value) else Nullable() - - let inline (?+?) (x : Nullable<_>) (y: Nullable<_>) = if x.HasValue && y.HasValue then Nullable(x.Value + y.Value) else Nullable() - - let inline (?-) (x : Nullable<_>) y = if x.HasValue then Nullable(x.Value - y) else Nullable() - - let inline (-?) x (y: Nullable<_>) = if y.HasValue then Nullable(x - y.Value) else Nullable() - - let inline (?-?) (x : Nullable<_>) (y: Nullable<_>) = if x.HasValue && y.HasValue then Nullable(x.Value - y.Value) else Nullable() - - let inline ( ?* ) (x : Nullable<_>) y = if x.HasValue then Nullable(x.Value * y) else Nullable() - - let inline ( *? ) x (y: Nullable<_>) = if y.HasValue then Nullable(x * y.Value) else Nullable() - - let inline ( ?*? ) (x : Nullable<_>) (y: Nullable<_>) = if x.HasValue && y.HasValue then Nullable(x.Value * y.Value) else Nullable() - - let inline ( ?% ) (x : Nullable<_>) y = if x.HasValue then Nullable(x.Value % y) else Nullable() - - let inline ( %? ) x (y: Nullable<_>) = if y.HasValue then Nullable(x % y.Value) else Nullable() - - let inline ( ?%? ) (x : Nullable<_>) (y: Nullable<_>) = if x.HasValue && y.HasValue then Nullable(x.Value % y.Value) else Nullable() - - let inline ( ?/ ) (x : Nullable<_>) y = if x.HasValue then Nullable(x.Value / y) else Nullable() - - let inline ( /? ) x (y: Nullable<_>) = if y.HasValue then Nullable(x / y.Value) else Nullable() - - let inline ( ?/? ) (x : Nullable<_>) (y: Nullable<_>) = if x.HasValue && y.HasValue then Nullable(x.Value / y.Value) else Nullable() + let (?<>) (x: Nullable<'T>) (y: 'T) = + not (x ?= y) + + let (>=?) (x: 'T) (y: Nullable<'T>) = + y.HasValue && x >= y.Value + + let (>?) (x: 'T) (y: Nullable<'T>) = + y.HasValue && x > y.Value + + let (<=?) (x: 'T) (y: Nullable<'T>) = + y.HasValue && x <= y.Value + + let () = + y.HasValue && x < y.Value + + let (=?) (x: 'T) (y: Nullable<'T>) = + y.HasValue && x = y.Value + + let (<>?) (x: 'T) (y: Nullable<'T>) = + not (x =? y) + + let (?>=?) (x: Nullable<'T>) (y: Nullable<'T>) = + (x.HasValue && y.HasValue && x.Value >= y.Value) + + let (?>?) (x: Nullable<'T>) (y: Nullable<'T>) = + (x.HasValue && y.HasValue && x.Value > y.Value) + + let (?<=?) (x: Nullable<'T>) (y: Nullable<'T>) = + (x.HasValue && y.HasValue && x.Value <= y.Value) + + let (?) (y: Nullable<'T>) = + (x.HasValue && y.HasValue && x.Value < y.Value) + + let (?=?) (x: Nullable<'T>) (y: Nullable<'T>) = + (not x.HasValue && not y.HasValue) + || (x.HasValue && y.HasValue && x.Value = y.Value) + + let (?<>?) (x: Nullable<'T>) (y: Nullable<'T>) = + not (x ?=? y) + + let inline (?+) (x: Nullable<_>) y = + if x.HasValue then + Nullable(x.Value + y) + else + Nullable() + + let inline (+?) x (y: Nullable<_>) = + if y.HasValue then + Nullable(x + y.Value) + else + Nullable() + + let inline (?+?) (x: Nullable<_>) (y: Nullable<_>) = + if x.HasValue && y.HasValue then + Nullable(x.Value + y.Value) + else + Nullable() + + let inline (?-) (x: Nullable<_>) y = + if x.HasValue then + Nullable(x.Value - y) + else + Nullable() + + let inline (-?) x (y: Nullable<_>) = + if y.HasValue then + Nullable(x - y.Value) + else + Nullable() + + let inline (?-?) (x: Nullable<_>) (y: Nullable<_>) = + if x.HasValue && y.HasValue then + Nullable(x.Value - y.Value) + else + Nullable() + + let inline (?*) (x: Nullable<_>) y = + if x.HasValue then + Nullable(x.Value * y) + else + Nullable() + + let inline ( *? ) x (y: Nullable<_>) = + if y.HasValue then + Nullable(x * y.Value) + else + Nullable() + + let inline (?*?) (x: Nullable<_>) (y: Nullable<_>) = + if x.HasValue && y.HasValue then + Nullable(x.Value * y.Value) + else + Nullable() + + let inline (?%) (x: Nullable<_>) y = + if x.HasValue then + Nullable(x.Value % y) + else + Nullable() + + let inline (%?) x (y: Nullable<_>) = + if y.HasValue then + Nullable(x % y.Value) + else + Nullable() + + let inline (?%?) (x: Nullable<_>) (y: Nullable<_>) = + if x.HasValue && y.HasValue then + Nullable(x.Value % y.Value) + else + Nullable() + + let inline (?/) (x: Nullable<_>) y = + if x.HasValue then + Nullable(x.Value / y) + else + Nullable() + + let inline (/?) x (y: Nullable<_>) = + if y.HasValue then + Nullable(x / y.Value) + else + Nullable() + + let inline (?/?) (x: Nullable<_>) (y: Nullable<_>) = + if x.HasValue && y.HasValue then + Nullable(x.Value / y.Value) + else + Nullable() [] [] module Nullable = [] - let inline uint8 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.byte value.Value) else Nullable() + let inline uint8 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.byte value.Value) + else + Nullable() [] - let inline int8 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.sbyte value.Value) else Nullable() + let inline int8 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.sbyte value.Value) + else + Nullable() [] - let inline byte (value:Nullable<_>) = if value.HasValue then Nullable(Operators.byte value.Value) else Nullable() + let inline byte (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.byte value.Value) + else + Nullable() [] - let inline sbyte (value:Nullable<_>) = if value.HasValue then Nullable(Operators.sbyte value.Value) else Nullable() + let inline sbyte (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.sbyte value.Value) + else + Nullable() [] - let inline int16 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.int16 value.Value) else Nullable() + let inline int16 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.int16 value.Value) + else + Nullable() [] - let inline uint16 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.uint16 value.Value) else Nullable() + let inline uint16 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.uint16 value.Value) + else + Nullable() [] - let inline int (value:Nullable<_>) = if value.HasValue then Nullable(Operators.int value.Value) else Nullable() + let inline int (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.int value.Value) + else + Nullable() [] - let inline uint (value: Nullable<_>) = if value.HasValue then Nullable(Operators.uint value.Value) else Nullable() - + let inline uint (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.uint value.Value) + else + Nullable() + [] - let inline enum (value:Nullable< int32 >) = if value.HasValue then Nullable(Operators.enum value.Value) else Nullable() + let inline enum (value: Nullable) = + if value.HasValue then + Nullable(Operators.enum value.Value) + else + Nullable() [] - let inline int32 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.int32 value.Value) else Nullable() + let inline int32 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.int32 value.Value) + else + Nullable() [] - let inline uint32 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.uint32 value.Value) else Nullable() + let inline uint32 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.uint32 value.Value) + else + Nullable() [] - let inline int64 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.int64 value.Value) else Nullable() + let inline int64 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.int64 value.Value) + else + Nullable() [] - let inline uint64 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.uint64 value.Value) else Nullable() + let inline uint64 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.uint64 value.Value) + else + Nullable() [] - let inline float32 (value:Nullable<_>) = if value.HasValue then Nullable(Operators.float32 value.Value) else Nullable() + let inline float32 (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.float32 value.Value) + else + Nullable() [] - let inline float (value:Nullable<_>) = if value.HasValue then Nullable(Operators.float value.Value) else Nullable() + let inline float (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.float value.Value) + else + Nullable() [] - let inline single (value:Nullable<_>) = if value.HasValue then Nullable(Operators.float32 value.Value) else Nullable() + let inline single (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.float32 value.Value) + else + Nullable() [] - let inline double (value:Nullable<_>) = if value.HasValue then Nullable(Operators.float value.Value) else Nullable() + let inline double (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.float value.Value) + else + Nullable() [] - let inline nativeint (value:Nullable<_>) = if value.HasValue then Nullable(Operators.nativeint value.Value) else Nullable() + let inline nativeint (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.nativeint value.Value) + else + Nullable() [] - let inline unativeint (value:Nullable<_>) = if value.HasValue then Nullable(Operators.unativeint value.Value) else Nullable() + let inline unativeint (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.unativeint value.Value) + else + Nullable() [] - let inline decimal (value:Nullable<_>) = if value.HasValue then Nullable(Operators.decimal value.Value) else Nullable() + let inline decimal (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.decimal value.Value) + else + Nullable() [] - let inline char (value:Nullable<_>) = if value.HasValue then Nullable(Operators.char value.Value) else Nullable() + let inline char (value: Nullable<_>) = + if value.HasValue then + Nullable(Operators.char value.Value) + else + Nullable() diff --git a/src/FSharp.Core/QueryExtensions.fs b/src/FSharp.Core/QueryExtensions.fs index d7aead4813b..f9d0ffd72fb 100644 --- a/src/FSharp.Core/QueryExtensions.fs +++ b/src/FSharp.Core/QueryExtensions.fs @@ -11,274 +11,336 @@ open Microsoft.FSharp.Quotations open Microsoft.FSharp.Quotations.DerivedPatterns open Microsoft.FSharp.Reflection open Microsoft.FSharp.Linq.RuntimeHelpers +open System.Collections +open System.Collections.Concurrent open System.Collections.Generic open System.Linq open System.Linq.Expressions +open System.Reflection // ---------------------------------------------------------------------------- -/// A type used to reconstruct a grouping after applying a mutable->immutable mapping transformation +/// A type used to reconstruct a grouping after applying a mutable->immutable mapping transformation /// on a result of a query. -type Grouping<'K, 'T>(key:'K, values:seq<'T>) = - interface System.Linq.IGrouping<'K, 'T> with +type Grouping<'K, 'T>(key: 'K, values: seq<'T>) = + interface IGrouping<'K, 'T> with member _.Key = key - interface System.Collections.IEnumerable with - member _.GetEnumerator() = values.GetEnumerator() :> System.Collections.IEnumerator + interface IEnumerable with + member _.GetEnumerator() = + values.GetEnumerator() :> IEnumerator - interface System.Collections.Generic.IEnumerable<'T> with - member _.GetEnumerator() = values.GetEnumerator() + interface Generic.IEnumerable<'T> with + member _.GetEnumerator() = + values.GetEnumerator() -module internal Adapters = +module internal Adapters = - let memoize f = - let d = new System.Collections.Concurrent.ConcurrentDictionary(HashIdentity.Structural) - fun x -> d.GetOrAdd(x, fun r -> f r) + let memoize f = + let d = new ConcurrentDictionary(HashIdentity.Structural) - let isPartiallyImmutableRecord : Type -> bool = - memoize (fun t -> - FSharpType.IsRecord t && - not (FSharpType.GetRecordFields t |> Array.forall (fun f -> f.CanWrite)) ) + fun x -> d.GetOrAdd(x, (fun r -> f r)) - let MemberInitializationHelperMeth = + let isPartiallyImmutableRecord: Type -> bool = + memoize (fun t -> + FSharpType.IsRecord t + && not (FSharpType.GetRecordFields t |> Array.forall (fun f -> f.CanWrite))) + + let MemberInitializationHelperMeth = methodhandleof (fun x -> LeafExpressionConverter.MemberInitializationHelper x) - |> System.Reflection.MethodInfo.GetMethodFromHandle - :?> System.Reflection.MethodInfo + |> MethodInfo.GetMethodFromHandle + :?> MethodInfo - let NewAnonymousObjectHelperMeth = + let NewAnonymousObjectHelperMeth = methodhandleof (fun x -> LeafExpressionConverter.NewAnonymousObjectHelper x) - |> System.Reflection.MethodInfo.GetMethodFromHandle - :?> System.Reflection.MethodInfo + |> MethodInfo.GetMethodFromHandle + :?> MethodInfo - // The following patterns are used to recognize object construction + // The following patterns are used to recognize object construction // using the 'new O(Prop1 = , Prop2 = )' syntax /// Recognize sequential series written as (... ((; ); ); ...) let (|LeftSequentialSeries|) e = let rec leftSequentialSeries acc e = - match e with - | Patterns.Sequential(e1, e2) -> leftSequentialSeries (e2 :: acc) e1 + match e with + | Patterns.Sequential (e1, e2) -> leftSequentialSeries (e2 :: acc) e1 | _ -> e :: acc + leftSequentialSeries [] e - /// Tests whether a list consists only of assignments of properties of the + /// Tests whether a list consists only of assignments of properties of the /// given variable, null values (ignored) and ends by returning the given variable /// (pattern returns only property assignments) - let (|PropSetList|_|) varArg (list:Expr list) = - let rec propSetList acc x = - match x with + let (|PropSetList|_|) varArg (list: Expr list) = + let rec propSetList acc x = + match x with // detect " v.X <- y" - | ((Patterns.PropertySet(Some(Patterns.Var var), _, _, _)) as p) :: xs when var = varArg -> + | ((Patterns.PropertySet (Some (Patterns.Var var), _, _, _)) as p) :: xs when var = varArg -> propSetList (p :: acc) xs // skip unit values | (Patterns.Value (v, _)) :: xs when v = null -> propSetList acc xs // detect "v" - | [Patterns.Var var] when var = varArg -> Some acc + | [ Patterns.Var var ] when var = varArg -> Some acc | _ -> None + propSetList [] list /// Recognize object construction written using 'new O(Prop1 = , Prop2 = , ...)' - let (|ObjectConstruction|_|) e = + let (|ObjectConstruction|_|) e = match e with - | Patterns.Let ( var, (Patterns.NewObject(_, []) as init), LeftSequentialSeries propSets ) -> - match propSets with + | Patterns.Let (var, (Patterns.NewObject (_, []) as init), LeftSequentialSeries propSets) -> + match propSets with | PropSetList var propSets -> Some(var, init, propSets) | _ -> None | _ -> None - - // Get arrays of types & map of transformations - let tupleTypes = - [| typedefof>, typedefof> - typedefof<_ * _>, typedefof> - typedefof<_ * _ * _>, typedefof> - typedefof<_ * _ * _ * _>, typedefof> - typedefof<_ * _ * _ * _ * _>, typedefof> - typedefof<_ * _ * _ * _ * _ * _>, typedefof> - typedefof<_ * _ * _ * _ * _ * _ * _>, typedefof> - typedefof<_ * _ * _ * _ * _ * _ * _ * _>, typedefof> |] + let tupleTypes = + [| + typedefof>, typedefof> + typedefof<_ * _>, typedefof> + typedefof<_ * _ * _>, typedefof> + typedefof<_ * _ * _ * _>, typedefof> + typedefof<_ * _ * _ * _ * _>, typedefof> + typedefof<_ * _ * _ * _ * _ * _>, typedefof> + typedefof<_ * _ * _ * _ * _ * _ * _>, typedefof> + typedefof<_ * _ * _ * _ * _ * _ * _ * _>, typedefof> + |] + let anonObjectTypes = tupleTypes |> Array.map snd - let tupleToAnonTypeMap = - let t = new Dictionary() - for (k,v) in tupleTypes do t.[k] <- v - t - let anonToTupleTypeMap = - let t = new Dictionary() - for (k,v) in tupleTypes do t.[v] <- k + let tupleToAnonTypeMap = + let t = new Dictionary() + + for (k, v) in tupleTypes do + t.[k] <- v + t + let anonToTupleTypeMap = + let t = new Dictionary() + + for (k, v) in tupleTypes do + t.[v] <- k + + t /// Recognize anonymous type construction written using 'new AnonymousObject(, , ...)' - let (|NewAnonymousObject|_|) e = + let (|NewAnonymousObject|_|) e = match e with - | Patterns.NewObject(ctor,args) when - let dty = ctor.DeclaringType - dty.IsGenericType && anonToTupleTypeMap.ContainsKey (dty.GetGenericTypeDefinition()) -> - Some (ctor, args) + | Patterns.NewObject (ctor, args) when + let dty = ctor.DeclaringType + + dty.IsGenericType + && anonToTupleTypeMap.ContainsKey(dty.GetGenericTypeDefinition()) + -> + Some(ctor, args) | _ -> None - let OneNewAnonymousObject (args:Expr list) = + let OneNewAnonymousObject (args: Expr list) = // Will fit into a single tuple type let typ = anonObjectTypes.[args.Length - 1] let typ = typ.MakeGenericType [| for a in args -> a.Type |] let ctor = typ.GetConstructors().[0] - let res = Expr.NewObject (ctor, args) - assert (match res with NewAnonymousObject _ -> true | _ -> false) + let res = Expr.NewObject(ctor, args) + + assert + (match res with + | NewAnonymousObject _ -> true + | _ -> false) + res - let rec NewAnonymousObject (args:Expr list) : Expr = - match args with + let rec NewAnonymousObject (args: Expr list) : Expr = + match args with | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: tail -> // Too long to fit single tuple - nested tuple after first 7 - OneNewAnonymousObject [ x1; x2; x3; x4; x5; x6; x7; NewAnonymousObject (x8 :: tail) ] - | args -> - OneNewAnonymousObject args + OneNewAnonymousObject [ x1; x2; x3; x4; x5; x6; x7; NewAnonymousObject(x8 :: tail) ] + | args -> OneNewAnonymousObject args - let AnonymousObjectGet (e:Expr,i:int) = - // Recursively generate tuple get + let AnonymousObjectGet (e: Expr, i: int) = + // Recursively generate tuple get // (may be nested e.g. TupleGet(, 9) ~> .Item8.Item3) - let rec walk i (inst:Expr) (newType:Type) = + let rec walk i (inst: Expr) (newType: Type) = // Get property (at most the last one) - let propInfo = newType.GetProperty ("Item" + string (1 + min i 7)) - let res = Expr.PropertyGet (inst, propInfo) + let propInfo = newType.GetProperty("Item" + string (1 + min i 7)) + let res = Expr.PropertyGet(inst, propInfo) // Do we need to add another property get for the last property? - if i < 7 then res - else walk (i - 7) res (newType.GetGenericArguments().[7]) - + if i < 7 then + res + else + walk (i - 7) res (newType.GetGenericArguments().[7]) + walk i e e.Type - let RewriteTupleType (ty:Type) conv = - // Tuples are generic, so lookup only for generic types - assert ty.IsGenericType + let RewriteTupleType (ty: Type) conv = + // Tuples are generic, so lookup only for generic types + assert ty.IsGenericType let generic = ty.GetGenericTypeDefinition() + match tupleToAnonTypeMap.TryGetValue generic with | true, mutableTupleType -> // Recursively transform type arguments - mutableTupleType.MakeGenericType (ty.GetGenericArguments() |> Array.toList |> conv |> Array.ofList) - | _ -> + mutableTupleType.MakeGenericType(ty.GetGenericArguments() |> Array.toList |> conv |> Array.ofList) + | _ -> assert false failwith "unreachable" - let (|RecordFieldGetSimplification|_|) (expr:Expr) = - match expr with - | Patterns.PropertyGet(Some (Patterns.NewRecord(typ,els)),propInfo,[]) -> - let fields = Microsoft.FSharp.Reflection.FSharpType.GetRecordFields(typ,System.Reflection.BindingFlags.Public|||System.Reflection.BindingFlags.NonPublic) - match fields |> Array.tryFindIndex (fun p -> p = propInfo) with + let (|RecordFieldGetSimplification|_|) (expr: Expr) = + match expr with + | Patterns.PropertyGet (Some (Patterns.NewRecord (typ, els)), propInfo, []) -> + let fields = + Microsoft.FSharp.Reflection.FSharpType.GetRecordFields( + typ, + BindingFlags.Public ||| BindingFlags.NonPublic + ) + + match fields |> Array.tryFindIndex (fun p -> p = propInfo) with | None -> None - | Some i -> if i < els.Length then Some els.[i] else None + | Some i -> + if i < els.Length then + Some els.[i] + else + None | _ -> None - /// The generic MethodInfo for Select function /// Describes how we got from productions of immutable objects to productions of anonymous objects, with enough information /// that we can invert the process in final query results. [] - type ConversionDescription = + type ConversionDescription = | TupleConv of ConversionDescription list | RecordConv of Type * ConversionDescription list - | GroupingConv of (* origKeyType: *) Type * (* origElemType: *) Type * ConversionDescription + | GroupingConv (* origKeyType: *) of Type (* origElemType: *) * Type * ConversionDescription | SeqConv of ConversionDescription | NoConv /// Given an type involving immutable tuples and records, logically corresponding to the type produced at a /// "yield" or "select", convert it to a type involving anonymous objects according to the conversion data. - let rec ConvImmutableTypeToMutableType conv ty = - match conv with - | TupleConv convs -> + let rec ConvImmutableTypeToMutableType conv ty = + match conv with + | TupleConv convs -> assert (FSharpType.IsTuple ty) - match convs with + + match convs with | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: tail -> - RewriteTupleType ty (List.map2 ConvImmutableTypeToMutableType [x1;x2;x3;x4;x5;x6;x7;TupleConv (x8 :: tail)]) - | _ -> - RewriteTupleType ty (List.map2 ConvImmutableTypeToMutableType convs) - | RecordConv (_,convs) -> + let els = [ x1; x2; x3; x4; x5; x6; x7; TupleConv(x8 :: tail) ] + RewriteTupleType ty (List.map2 ConvImmutableTypeToMutableType els) + | _ -> RewriteTupleType ty (List.map2 ConvImmutableTypeToMutableType convs) + | RecordConv (_, convs) -> assert (isPartiallyImmutableRecord ty) let types = [| for f in FSharpType.GetRecordFields ty -> f.PropertyType |] - ConvImmutableTypeToMutableType (TupleConv convs) (FSharpType.MakeTupleType types) - | GroupingConv (_keyTy,_elemTy,conv) -> - assert ty.IsGenericType - assert (ty.GetGenericTypeDefinition() = typedefof>) + ConvImmutableTypeToMutableType (TupleConv convs) (FSharpType.MakeTupleType types) + | GroupingConv (_keyTy, _elemTy, conv) -> + assert ty.IsGenericType + assert (ty.GetGenericTypeDefinition() = typedefof>) let keyt1 = ty.GetGenericArguments().[0] let valt1 = ty.GetGenericArguments().[1] - typedefof>.MakeGenericType [| keyt1; ConvImmutableTypeToMutableType conv valt1 |] - | SeqConv conv -> + typedefof>.MakeGenericType [| keyt1; ConvImmutableTypeToMutableType conv valt1 |] + | SeqConv conv -> assert ty.IsGenericType let isIQ = ty.GetGenericTypeDefinition() = typedefof> - assert (ty.GetGenericTypeDefinition() = typedefof> || ty.GetGenericTypeDefinition() = typedefof>) + + assert + (ty.GetGenericTypeDefinition() = typedefof> + || ty.GetGenericTypeDefinition() = typedefof>) + let elemt1 = ty.GetGenericArguments().[0] let args = [| ConvImmutableTypeToMutableType conv elemt1 |] - if isIQ then typedefof>.MakeGenericType args else typedefof>.MakeGenericType args + + if isIQ then + typedefof>.MakeGenericType args + else + typedefof>.MakeGenericType args | NoConv -> ty - let IsNewAnonymousObjectHelperQ = - let mhandle = (methodhandleof (fun x -> LeafExpressionConverter.NewAnonymousObjectHelper x)) - let minfo = (System.Reflection.MethodInfo.GetMethodFromHandle mhandle) :?> System.Reflection.MethodInfo - let gmd = minfo.GetGenericMethodDefinition() - (fun tm -> + let IsNewAnonymousObjectHelperQ = + let mhandle = + (methodhandleof (fun x -> LeafExpressionConverter.NewAnonymousObjectHelper x)) + + let minfo = (MethodInfo.GetMethodFromHandle mhandle) :?> MethodInfo + + let gmd = minfo.GetGenericMethodDefinition() + + (fun tm -> match tm with - | Patterns.Call(_obj,minfo2,_args) -> minfo2.IsGenericMethod && (gmd = minfo2.GetGenericMethodDefinition()) + | Patterns.Call (_obj, minfo2, _args) -> + minfo2.IsGenericMethod && (gmd = minfo2.GetGenericMethodDefinition()) | _ -> false) /// Cleanup the use of property-set object constructions in leaf expressions that form parts of F# queries. - let rec CleanupLeaf expr = - if IsNewAnonymousObjectHelperQ expr then expr else // this has already been cleaned up, don't do it twice - - // rewrite bottom-up - let expr = - match expr with - | ExprShape.ShapeCombination(comb,args) -> match args with [] -> expr | _ -> ExprShape.RebuildShapeCombination(comb,List.map CleanupLeaf args) - | ExprShape.ShapeLambda(v,body) -> Expr.Lambda (v, CleanupLeaf body) - | ExprShape.ShapeVar _ -> expr - match expr with - - // Detect all object construction expressions - wrap them in 'MemberInitializationHelper' - // so that it can be translated to Expression.MemberInit - | ObjectConstruction(var, init, propSets) -> - // Wrap object initialization into a value ( - let methInfo = MemberInitializationHelperMeth.MakeGenericMethod [| var.Type |] - Expr.Call (methInfo, [ List.reduceBack (fun a b -> Expr.Sequential (a,b)) (propSets @ [init]) ]) - - // Detect all anonymous type constructions - wrap them in 'NewAnonymousObjectHelper' - // so that it can be translated to Expression.New with member arguments. - | NewAnonymousObject(ctor, args) -> - let methInfo = NewAnonymousObjectHelperMeth.MakeGenericMethod [| ctor.DeclaringType |] - Expr.Call (methInfo, [ Expr.NewObject (ctor,args) ]) - | expr -> + let rec CleanupLeaf expr = + if IsNewAnonymousObjectHelperQ expr then expr + else // this has already been cleaned up, don't do it twice + + // rewrite bottom-up + let expr = + match expr with + | ExprShape.ShapeCombination (comb, args) -> + match args with + | [] -> expr + | _ -> ExprShape.RebuildShapeCombination(comb, List.map CleanupLeaf args) + | ExprShape.ShapeLambda (v, body) -> Expr.Lambda(v, CleanupLeaf body) + | ExprShape.ShapeVar _ -> expr + + match expr with + + // Detect all object construction expressions - wrap them in 'MemberInitializationHelper' + // so that it can be translated to Expression.MemberInit + | ObjectConstruction (var, init, propSets) -> + // Wrap object initialization into a value ( + let methInfo = MemberInitializationHelperMeth.MakeGenericMethod [| var.Type |] + Expr.Call(methInfo, [ List.reduceBack (fun a b -> Expr.Sequential(a, b)) (propSets @ [ init ]) ]) + + // Detect all anonymous type constructions - wrap them in 'NewAnonymousObjectHelper' + // so that it can be translated to Expression.New with member arguments. + | NewAnonymousObject (ctor, args) -> + let methInfo = + NewAnonymousObjectHelperMeth.MakeGenericMethod [| ctor.DeclaringType |] + + Expr.Call(methInfo, [ Expr.NewObject(ctor, args) ]) + | expr -> expr /// Simplify gets of tuples and gets of record fields. - let rec SimplifyConsumingExpr e = + let rec SimplifyConsumingExpr e = // rewrite bottom-up - let e = - match e with - | ExprShape.ShapeCombination(comb,args) -> ExprShape.RebuildShapeCombination(comb,List.map SimplifyConsumingExpr args) - | ExprShape.ShapeLambda(v,body) -> Expr.Lambda (v, SimplifyConsumingExpr body) + let e = + match e with + | ExprShape.ShapeCombination (comb, args) -> + ExprShape.RebuildShapeCombination(comb, List.map SimplifyConsumingExpr args) + | ExprShape.ShapeLambda (v, body) -> Expr.Lambda(v, SimplifyConsumingExpr body) | ExprShape.ShapeVar _ -> e + match e with - | Patterns.TupleGet(Patterns.NewTuple els,i) -> els.[i] - | RecordFieldGetSimplification newExpr -> newExpr + | Patterns.TupleGet (Patterns.NewTuple els, i) -> els.[i] + | RecordFieldGetSimplification newExpr -> newExpr | _ -> e /// Given the expression part of a "yield" or "select" which produces a result in terms of immutable tuples or immutable records, /// generate an equivalent expression yielding anonymous objects. Also return the conversion for the immutable-to-mutable correspondence /// so we can reverse this later. - let rec ProduceMoreMutables tipf expr = + let rec ProduceMoreMutables tipf expr = + + match expr with + // Replace immutable tuples by anonymous objects + | Patterns.NewTuple exprs -> + let argExprsNow, argScripts = + exprs |> List.map (ProduceMoreMutables tipf) |> List.unzip + + NewAnonymousObject argExprsNow, TupleConv argScripts - match expr with - // Replace immutable tuples by anonymous objects - | Patterns.NewTuple exprs -> - let argExprsNow, argScripts = exprs |> List.map (ProduceMoreMutables tipf) |> List.unzip - NewAnonymousObject argExprsNow, TupleConv argScripts + // Replace immutable records by anonymous objects + | Patterns.NewRecord (typ, args) when isPartiallyImmutableRecord typ -> + let argExprsNow, argScripts = + args |> List.map (ProduceMoreMutables tipf) |> List.unzip - // Replace immutable records by anonymous objects - | Patterns.NewRecord(typ, args) when isPartiallyImmutableRecord typ -> - let argExprsNow, argScripts = args |> List.map (ProduceMoreMutables tipf) |> List.unzip NewAnonymousObject argExprsNow, RecordConv(typ, argScripts) - | expr -> - tipf expr + | expr -> tipf expr - let MakeSeqConv conv = match conv with NoConv -> NoConv | _ -> SeqConv conv + let MakeSeqConv conv = + match conv with + | NoConv -> NoConv + | _ -> SeqConv conv diff --git a/src/FSharp.Core/array.fs b/src/FSharp.Core/array.fs index cf8ec3924f8..1dff8103bda 100644 --- a/src/FSharp.Core/array.fs +++ b/src/FSharp.Core/array.fs @@ -14,169 +14,229 @@ open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators /// Basic operations on arrays [] [] -module Array = +module Array = let inline checkNonNull argName arg = - if isNull arg then - nullArg argName + if isNull arg then nullArg argName - let inline indexNotFound() = raise (KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) + let inline indexNotFound () = + raise (KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) [] - let length (array: _[]) = + let length (array: _[]) = checkNonNull "array" array array.Length - + [] let inline last (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString - array.[array.Length-1] + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + array.[array.Length - 1] [] let tryLast (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then None - else Some array.[array.Length-1] + + if array.Length = 0 then + None + else + Some array.[array.Length - 1] [] - let inline init count initializer = Microsoft.FSharp.Primitives.Basics.Array.init count initializer + let inline init count initializer = + Microsoft.FSharp.Primitives.Basics.Array.init count initializer [] - let zeroCreate count = - if count < 0 then invalidArgInputMustBeNonNegative "count" count + let zeroCreate count = + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count [] let create (count: int) (value: 'T) = - if count < 0 then invalidArgInputMustBeNonNegative "count" count + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + let array: 'T[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count + for i = 0 to Operators.Checked.(-) array.Length 1 do // use checked arithmetic here to satisfy FxCop array.[i] <- value + array [] let tryHead (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then None - else Some array.[0] + + if array.Length = 0 then + None + else + Some array.[0] [] - let isEmpty (array: 'T[]) = + let isEmpty (array: 'T[]) = checkNonNull "array" array array.Length = 0 [] let tail (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" (SR.GetString(SR.notEnoughElements)) + + if array.Length = 0 then + invalidArg "array" (SR.GetString(SR.notEnoughElements)) + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 1 (array.Length - 1) array [] - let empty<'T> : 'T [] = [| |] + let empty<'T> : 'T[] = [||] [] - let inline blit (source: 'T[]) (sourceIndex: int) (target: 'T[]) (targetIndex: int) (count: int) = + let inline blit (source: 'T[]) (sourceIndex: int) (target: 'T[]) (targetIndex: int) (count: int) = Array.Copy(source, sourceIndex, target, targetIndex, count) - + let concatArrays (arrs: 'T[][]) : 'T[] = - let mutable acc = 0 + let mutable acc = 0 + for h in arrs do acc <- acc + h.Length - - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked acc - + + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked acc + let mutable j = 0 - for i = 0 to arrs.Length-1 do + + for i = 0 to arrs.Length - 1 do let h = arrs.[i] let len = h.Length Array.Copy(h, 0, res, j, len) j <- j + len - res + + res [] - let concat (arrays: seq<'T[]>) = + let concat (arrays: seq<'T[]>) = checkNonNull "arrays" arrays + match arrays with | :? ('T[][]) as ts -> ts |> concatArrays // avoid a clone, since we only read the array | _ -> arrays |> Seq.toArray |> concatArrays - + [] - let replicate count initial = - if count < 0 then invalidArgInputMustBeNonNegative "count" count - let arr: 'T array = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count - for i = 0 to arr.Length-1 do + let replicate count initial = + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + + let arr: 'T array = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count + + for i = 0 to arr.Length - 1 do arr.[i] <- initial + arr [] - let collect (mapping: 'T -> 'U[]) (array: 'T[]) : 'U[]= + let collect (mapping: 'T -> 'U[]) (array: 'T[]) : 'U[] = checkNonNull "array" array let len = array.Length let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked<'U[]> len - for i = 0 to result.Length-1 do + + for i = 0 to result.Length - 1 do result.[i] <- mapping array.[i] + concatArrays result - + [] let splitAt index (array: 'T[]) = checkNonNull "array" array - if index < 0 then invalidArgInputMustBeNonNegative "index" index - if array.Length < index then raise <| InvalidOperationException (SR.GetString(SR.notEnoughElements)) + + if index < 0 then + invalidArgInputMustBeNonNegative "index" index + + if array.Length < index then + raise <| InvalidOperationException(SR.GetString(SR.notEnoughElements)) + if index = 0 then - let right = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 array.Length array + let right = + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 array.Length array + [||], right elif index = array.Length then - let left = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 array.Length array - left, [||] + let left = + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 array.Length array + + left, [||] else let res1 = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 index array - let res2 = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked index (array.Length-index) array + + let res2 = + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked index (array.Length - index) array res1, res2 [] let take count (array: 'T[]) = checkNonNull "array" array - if count < 0 then invalidArgInputMustBeNonNegative "count" count - if count = 0 then + + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + + if count = 0 then empty else if count > array.Length then - raise <| InvalidOperationException (SR.GetString(SR.notEnoughElements)) + raise <| InvalidOperationException(SR.GetString(SR.notEnoughElements)) Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 count array [] - let takeWhile predicate (array: 'T[]) = + let takeWhile predicate (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then - empty + + if array.Length = 0 then + empty else let mutable count = 0 + while count < array.Length && predicate array.[count] do count <- count + 1 Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 count array - let inline countByImpl (comparer: IEqualityComparer<'SafeKey>) ([] projection: 'T->'SafeKey) ([] getKey: 'SafeKey->'Key) (array: 'T[]) = + let inline countByImpl + (comparer: IEqualityComparer<'SafeKey>) + ([] projection: 'T -> 'SafeKey) + ([] getKey: 'SafeKey -> 'Key) + (array: 'T[]) + = let length = array.Length - if length = 0 then Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 else - let dict = Dictionary comparer + if length = 0 then + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 + else + + let dict = Dictionary comparer - // Build the groupings - for v in array do - let safeKey = projection v - let mutable prev = Unchecked.defaultof<_> - if dict.TryGetValue(safeKey, &prev) then dict.[safeKey] <- prev + 1 else dict.[safeKey] <- 1 + // Build the groupings + for v in array do + let safeKey = projection v + let mutable prev = Unchecked.defaultof<_> - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked dict.Count - let mutable i = 0 - for group in dict do - res.[i] <- getKey group.Key, group.Value - i <- i + 1 - res + if dict.TryGetValue(safeKey, &prev) then + dict.[safeKey] <- prev + 1 + else + dict.[safeKey] <- 1 + + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked dict.Count + let mutable i = 0 + + for group in dict do + res.[i] <- getKey group.Key, group.Value + i <- i + 1 + + res // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance let countByValueType (projection: 'T -> 'Key) (array: 'T[]) = @@ -184,43 +244,56 @@ module Array = // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation let countByRefType (projection: 'T -> 'Key) (array: 'T[]) = - countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (projection t)) (fun sb -> sb.Value) array + countByImpl + RuntimeHelpers.StructBox<'Key>.Comparer + (fun t -> RuntimeHelpers.StructBox(projection t)) + (fun sb -> sb.Value) + array [] - let countBy (projection: 'T->'Key) (array: 'T[]) = + let countBy (projection: 'T -> 'Key) (array: 'T[]) = checkNonNull "array" array - if typeof<'Key>.IsValueType - then countByValueType projection array - else countByRefType projection array + + if typeof<'Key>.IsValueType then + countByValueType projection array + else + countByRefType projection array [] - let append (array1: 'T[]) (array2: 'T[]) = + let append (array1: 'T[]) (array2: 'T[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let n1 = array1.Length - let n2 = array2.Length - let res: 'T[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (n1 + n2) + let n1 = array1.Length + let n2 = array2.Length + + let res: 'T[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (n1 + n2) + Array.Copy(array1, 0, res, 0, n1) Array.Copy(array2, 0, res, n1, n2) - res + res [] let head (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString else array.[0] + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + else + array.[0] [] let copy (array: 'T[]) = checkNonNull "array" array (array.Clone() :?> 'T[]) // this is marginally faster - //let len = array.Length - //let res = zeroCreate len - //for i = 0 to len - 1 do - // res.[i] <- array.[i] - //res + //let len = array.Length + //let res = zeroCreate len + //for i = 0 to len - 1 do + // res.[i] <- array.[i] + //res [] - let toList array = + let toList array = checkNonNull "array" array List.ofArray array @@ -230,16 +303,19 @@ module Array = [] let indexed (array: 'T[]) = - checkNonNull "array" array + checkNonNull "array" array let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length - for i = 0 to res.Length-1 do + + for i = 0 to res.Length - 1 do res.[i] <- (i, array.[i]) + res [] - let inline iter ([] action) (array: 'T[]) = - checkNonNull "array" array - for i = 0 to array.Length-1 do + let inline iter ([] action) (array: 'T[]) = + checkNonNull "array" array + + for i = 0 to array.Length - 1 do action array.[i] [] @@ -249,7 +325,8 @@ module Array = let mutable i = 0 let hashSet = HashSet<'T>(HashIdentity.Structural<'T>) - for v in array do + + for v in array do if hashSet.Add(v) then temp.[i] <- v i <- i + 1 @@ -258,96 +335,127 @@ module Array = [] let inline map ([] mapping: 'T -> 'U) (array: 'T[]) = - checkNonNull "array" array - let res: 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length - for i = 0 to res.Length-1 do + checkNonNull "array" array + + let res: 'U[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length + + for i = 0 to res.Length - 1 do res.[i] <- mapping array.[i] + res [] - let iter2 action (array1: 'T[]) (array2: 'U[]) = + let iter2 action (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) - if array1.Length <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - for i = 0 to array1.Length-1 do + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (action) + + if array1.Length <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + for i = 0 to array1.Length - 1 do f.Invoke(array1.[i], array2.[i]) [] let distinctBy projection (array: 'T[]) = checkNonNull "array" array let length = array.Length - if length = 0 then Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 else - let temp = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length - let mutable i = 0 - let hashSet = HashSet<_>(HashIdentity.Structural<_>) - for v in array do - if hashSet.Add(projection v) then - temp.[i] <- v - i <- i + 1 + if length = 0 then + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 + else - Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 i temp + let temp = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length + let mutable i = 0 + let hashSet = HashSet<_>(HashIdentity.Structural<_>) + + for v in array do + if hashSet.Add(projection v) then + temp.[i] <- v + i <- i + 1 + + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 i temp [] - let map2 mapping (array1: 'T[]) (array2: 'U[]) = + let map2 mapping (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) - if array1.Length <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (mapping) + + if array1.Length <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array1.Length - for i = 0 to res.Length-1 do + + for i = 0 to res.Length - 1 do res.[i] <- f.Invoke(array1.[i], array2.[i]) + res [] - let map3 mapping (array1: 'T1[]) (array2: 'T2[]) (array3: 'T3[]) = + let map3 mapping (array1: 'T1[]) (array2: 'T2[]) (array3: 'T3[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 checkNonNull "array3" array3 - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(mapping) + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (mapping) let len1 = array1.Length - if len1 <> array2.Length || len1 <> array3.Length then invalidArg3ArraysDifferent "array1" "array2" "array3" len1 array2.Length array3.Length - + + if len1 <> array2.Length || len1 <> array3.Length then + invalidArg3ArraysDifferent "array1" "array2" "array3" len1 array2.Length array3.Length + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len1 - for i = 0 to res.Length-1 do + + for i = 0 to res.Length - 1 do res.[i] <- f.Invoke(array1.[i], array2.[i], array3.[i]) + res [] - let mapi2 mapping (array1: 'T[]) (array2: 'U[]) = + let mapi2 mapping (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(mapping) - if array1.Length <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array1.Length - for i = 0 to res.Length-1 do + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (mapping) + + if array1.Length <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array1.Length + + for i = 0 to res.Length - 1 do res.[i] <- f.Invoke(i, array1.[i], array2.[i]) + res [] let iteri action (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) - for i = 0 to array.Length-1 do + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (action) + + for i = 0 to array.Length - 1 do f.Invoke(i, array.[i]) [] - let iteri2 action (array1: 'T[]) (array2: 'U[]) = + let iteri2 action (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(action) - if array1.Length <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - for i = 0 to array1.Length-1 do + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (action) + + if array1.Length <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + for i = 0 to array1.Length - 1 do f.Invoke(i, array1.[i], array2.[i]) [] let mapi (mapping: int -> 'T -> 'U) (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (mapping) let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length - for i = 0 to array.Length-1 do + + for i = 0 to array.Length - 1 do res.[i] <- f.Invoke(i, array.[i]) + res [] @@ -365,9 +473,11 @@ module Array = checkNonNull "array" array let mutable state = false let mutable i = 0 + while not state && i < array.Length do state <- predicate array.[i] i <- i + 1 + state [] @@ -375,202 +485,365 @@ module Array = checkNonNull "array" array let mutable state = false let mutable i = 0 + while not state && i < array.Length do state <- value = array.[i] i <- i + 1 + state [] - let exists2 predicate (array1: _[]) (array2: _[]) = + let exists2 predicate (array1: _[]) (array2: _[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (predicate) let len1 = array1.Length - if len1 <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - let rec loop i = i < len1 && (f.Invoke(array1.[i], array2.[i]) || loop (i+1)) + + if len1 <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + let rec loop i = + i < len1 && (f.Invoke(array1.[i], array2.[i]) || loop (i + 1)) + loop 0 [] let forall (predicate: 'T -> bool) (array: 'T[]) = checkNonNull "array" array let len = array.Length - let rec loop i = i >= len || (predicate array.[i] && loop (i+1)) + + let rec loop i = + i >= len || (predicate array.[i] && loop (i + 1)) + loop 0 [] - let forall2 predicate (array1: _[]) (array2: _[]) = + let forall2 predicate (array1: _[]) (array2: _[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (predicate) let len1 = array1.Length - if len1 <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - let rec loop i = i >= len1 || (f.Invoke(array1.[i], array2.[i]) && loop (i+1)) + + if len1 <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + let rec loop i = + i >= len1 || (f.Invoke(array1.[i], array2.[i]) && loop (i + 1)) + loop 0 - let inline groupByImpl (comparer: IEqualityComparer<'SafeKey>) ([] keyf: 'T->'SafeKey) ([] getKey: 'SafeKey->'Key) (array: 'T[]) = + let inline groupByImpl + (comparer: IEqualityComparer<'SafeKey>) + ([] keyf: 'T -> 'SafeKey) + ([] getKey: 'SafeKey -> 'Key) + (array: 'T[]) + = let length = array.Length - if length = 0 then Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 else - let dict = Dictionary<_, ResizeArray<_>> comparer - - // Build the groupings - for i = 0 to length - 1 do - let v = array.[i] - let safeKey = keyf v - let mutable prev = Unchecked.defaultof<_> - if dict.TryGetValue(safeKey, &prev) then - prev.Add v - else - let prev = ResizeArray () - dict.[safeKey] <- prev - prev.Add v - - // Return the array-of-arrays. - let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked dict.Count - let mutable i = 0 - for group in dict do - result.[i] <- getKey group.Key, group.Value.ToArray() - i <- i + 1 - result + if length = 0 then + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 + else + let dict = Dictionary<_, ResizeArray<_>> comparer + + // Build the groupings + for i = 0 to length - 1 do + let v = array.[i] + let safeKey = keyf v + let mutable prev = Unchecked.defaultof<_> + + if dict.TryGetValue(safeKey, &prev) then + prev.Add v + else + let prev = ResizeArray() + dict.[safeKey] <- prev + prev.Add v + + // Return the array-of-arrays. + let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked dict.Count + let mutable i = 0 + + for group in dict do + result.[i] <- getKey group.Key, group.Value.ToArray() + i <- i + 1 + + result // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let groupByValueType (keyf: 'T->'Key) (array: 'T[]) = groupByImpl HashIdentity.Structural<'Key> keyf id array + let groupByValueType (keyf: 'T -> 'Key) (array: 'T[]) = + groupByImpl HashIdentity.Structural<'Key> keyf id array // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let groupByRefType (keyf: 'T->'Key) (array: 'T[]) = groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) array + let groupByRefType (keyf: 'T -> 'Key) (array: 'T[]) = + groupByImpl + RuntimeHelpers.StructBox<'Key>.Comparer + (fun t -> RuntimeHelpers.StructBox(keyf t)) + (fun sb -> sb.Value) + array [] - let groupBy (projection: 'T->'Key) (array: 'T[]) = + let groupBy (projection: 'T -> 'Key) (array: 'T[]) = checkNonNull "array" array - if typeof<'Key>.IsValueType - then groupByValueType projection array - else groupByRefType projection array + + if typeof<'Key>.IsValueType then + groupByValueType projection array + else + groupByRefType projection array [] - let pick chooser (array: _[]) = - checkNonNull "array" array - let rec loop i = - if i >= array.Length then - indexNotFound() - else - match chooser array.[i] with - | None -> loop(i+1) + let pick chooser (array: _[]) = + checkNonNull "array" array + + let rec loop i = + if i >= array.Length then + indexNotFound () + else + match chooser array.[i] with + | None -> loop (i + 1) | Some res -> res - loop 0 + + loop 0 [] - let tryPick chooser (array: _[]) = - checkNonNull "array" array - let rec loop i = - if i >= array.Length then None else - match chooser array.[i] with - | None -> loop(i+1) - | res -> res - loop 0 - + let tryPick chooser (array: _[]) = + checkNonNull "array" array + + let rec loop i = + if i >= array.Length then + None + else + match chooser array.[i] with + | None -> loop (i + 1) + | res -> res + + loop 0 + [] - let choose (chooser: 'T -> 'U Option) (array: 'T[]) = - checkNonNull "array" array - + let choose (chooser: 'T -> 'U Option) (array: 'T[]) = + checkNonNull "array" array + let mutable i = 0 let mutable first = Unchecked.defaultof<'U> let mutable found = false + while i < array.Length && not found do let element = array.[i] - match chooser element with + + match chooser element with | None -> i <- i + 1 - | Some b -> first <- b; found <- true - + | Some b -> + first <- b + found <- true + if i <> array.Length then - let chunk1: 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked ((array.Length >>> 2) + 1) + let chunk1: 'U[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked ((array.Length >>> 2) + 1) + chunk1.[0] <- first - let mutable count = 1 - i <- i + 1 + let mutable count = 1 + i <- i + 1 + while count < chunk1.Length && i < array.Length do - let element = array.[i] + let element = array.[i] + match chooser element with | None -> () - | Some b -> chunk1.[count] <- b - count <- count + 1 + | Some b -> + chunk1.[count] <- b + count <- count + 1 + i <- i + 1 - - if i < array.Length then - let chunk2: 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (array.Length-i) + + if i < array.Length then + let chunk2: 'U[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (array.Length - i) + count <- 0 + while i < array.Length do - let element = array.[i] + let element = array.[i] + match chooser element with | None -> () - | Some b -> chunk2.[count] <- b - count <- count + 1 + | Some b -> + chunk2.[count] <- b + count <- count + 1 + i <- i + 1 - let res: 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (chunk1.Length + count) + let res: 'U[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (chunk1.Length + count) + Array.Copy(chunk1, res, chunk1.Length) Array.Copy(chunk2, 0, res, chunk1.Length, count) res else - Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 count chunk1 + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 count chunk1 else empty - // The filter module is a space and performance for Array.filter based optimization that uses - // a bitarray to store the results of the filtering of every element of the array. This means + // The filter module is a space and performance for Array.filter based optimization that uses + // a bitarray to store the results of the filtering of every element of the array. This means // that the only additional temporary garbage that needs to be allocated is {array.Length/8} bytes. // - // Other optimizations include: + // Other optimizations include: // - arrays < 32 elements don't allocate any garbage at all // - when the predicate yields consecutive runs of true data that is >= 32 elements (and fall // into maskArray buckets) are copied in chunks using System.Array.Copy module Filter = - let private populateMask<'a> (f: 'a->bool) (src: array<'a>) (maskArray: array) = + let private populateMask<'a> (f: 'a -> bool) (src: array<'a>) (maskArray: array) = let mutable count = 0 - for maskIdx = 0 to maskArray.Length-1 do + + for maskIdx = 0 to maskArray.Length - 1 do let srcIdx = maskIdx * 32 let mutable mask = 0u - if f src.[srcIdx+0x00] then mask <- mask ||| (1u <<< 0x00); count <- count + 1 - if f src.[srcIdx+0x01] then mask <- mask ||| (1u <<< 0x01); count <- count + 1 - if f src.[srcIdx+0x02] then mask <- mask ||| (1u <<< 0x02); count <- count + 1 - if f src.[srcIdx+0x03] then mask <- mask ||| (1u <<< 0x03); count <- count + 1 - if f src.[srcIdx+0x04] then mask <- mask ||| (1u <<< 0x04); count <- count + 1 - if f src.[srcIdx+0x05] then mask <- mask ||| (1u <<< 0x05); count <- count + 1 - if f src.[srcIdx+0x06] then mask <- mask ||| (1u <<< 0x06); count <- count + 1 - if f src.[srcIdx+0x07] then mask <- mask ||| (1u <<< 0x07); count <- count + 1 - if f src.[srcIdx+0x08] then mask <- mask ||| (1u <<< 0x08); count <- count + 1 - if f src.[srcIdx+0x09] then mask <- mask ||| (1u <<< 0x09); count <- count + 1 - if f src.[srcIdx+0x0A] then mask <- mask ||| (1u <<< 0x0A); count <- count + 1 - if f src.[srcIdx+0x0B] then mask <- mask ||| (1u <<< 0x0B); count <- count + 1 - if f src.[srcIdx+0x0C] then mask <- mask ||| (1u <<< 0x0C); count <- count + 1 - if f src.[srcIdx+0x0D] then mask <- mask ||| (1u <<< 0x0D); count <- count + 1 - if f src.[srcIdx+0x0E] then mask <- mask ||| (1u <<< 0x0E); count <- count + 1 - if f src.[srcIdx+0x0F] then mask <- mask ||| (1u <<< 0x0F); count <- count + 1 - if f src.[srcIdx+0x10] then mask <- mask ||| (1u <<< 0x10); count <- count + 1 - if f src.[srcIdx+0x11] then mask <- mask ||| (1u <<< 0x11); count <- count + 1 - if f src.[srcIdx+0x12] then mask <- mask ||| (1u <<< 0x12); count <- count + 1 - if f src.[srcIdx+0x13] then mask <- mask ||| (1u <<< 0x13); count <- count + 1 - if f src.[srcIdx+0x14] then mask <- mask ||| (1u <<< 0x14); count <- count + 1 - if f src.[srcIdx+0x15] then mask <- mask ||| (1u <<< 0x15); count <- count + 1 - if f src.[srcIdx+0x16] then mask <- mask ||| (1u <<< 0x16); count <- count + 1 - if f src.[srcIdx+0x17] then mask <- mask ||| (1u <<< 0x17); count <- count + 1 - if f src.[srcIdx+0x18] then mask <- mask ||| (1u <<< 0x18); count <- count + 1 - if f src.[srcIdx+0x19] then mask <- mask ||| (1u <<< 0x19); count <- count + 1 - if f src.[srcIdx+0x1A] then mask <- mask ||| (1u <<< 0x1A); count <- count + 1 - if f src.[srcIdx+0x1B] then mask <- mask ||| (1u <<< 0x1B); count <- count + 1 - if f src.[srcIdx+0x1C] then mask <- mask ||| (1u <<< 0x1C); count <- count + 1 - if f src.[srcIdx+0x1D] then mask <- mask ||| (1u <<< 0x1D); count <- count + 1 - if f src.[srcIdx+0x1E] then mask <- mask ||| (1u <<< 0x1E); count <- count + 1 - if f src.[srcIdx+0x1F] then mask <- mask ||| (1u <<< 0x1F); count <- count + 1 + + if f src.[srcIdx + 0x00] then + mask <- mask ||| (1u <<< 0x00) + count <- count + 1 + + if f src.[srcIdx + 0x01] then + mask <- mask ||| (1u <<< 0x01) + count <- count + 1 + + if f src.[srcIdx + 0x02] then + mask <- mask ||| (1u <<< 0x02) + count <- count + 1 + + if f src.[srcIdx + 0x03] then + mask <- mask ||| (1u <<< 0x03) + count <- count + 1 + + if f src.[srcIdx + 0x04] then + mask <- mask ||| (1u <<< 0x04) + count <- count + 1 + + if f src.[srcIdx + 0x05] then + mask <- mask ||| (1u <<< 0x05) + count <- count + 1 + + if f src.[srcIdx + 0x06] then + mask <- mask ||| (1u <<< 0x06) + count <- count + 1 + + if f src.[srcIdx + 0x07] then + mask <- mask ||| (1u <<< 0x07) + count <- count + 1 + + if f src.[srcIdx + 0x08] then + mask <- mask ||| (1u <<< 0x08) + count <- count + 1 + + if f src.[srcIdx + 0x09] then + mask <- mask ||| (1u <<< 0x09) + count <- count + 1 + + if f src.[srcIdx + 0x0A] then + mask <- mask ||| (1u <<< 0x0A) + count <- count + 1 + + if f src.[srcIdx + 0x0B] then + mask <- mask ||| (1u <<< 0x0B) + count <- count + 1 + + if f src.[srcIdx + 0x0C] then + mask <- mask ||| (1u <<< 0x0C) + count <- count + 1 + + if f src.[srcIdx + 0x0D] then + mask <- mask ||| (1u <<< 0x0D) + count <- count + 1 + + if f src.[srcIdx + 0x0E] then + mask <- mask ||| (1u <<< 0x0E) + count <- count + 1 + + if f src.[srcIdx + 0x0F] then + mask <- mask ||| (1u <<< 0x0F) + count <- count + 1 + + if f src.[srcIdx + 0x10] then + mask <- mask ||| (1u <<< 0x10) + count <- count + 1 + + if f src.[srcIdx + 0x11] then + mask <- mask ||| (1u <<< 0x11) + count <- count + 1 + + if f src.[srcIdx + 0x12] then + mask <- mask ||| (1u <<< 0x12) + count <- count + 1 + + if f src.[srcIdx + 0x13] then + mask <- mask ||| (1u <<< 0x13) + count <- count + 1 + + if f src.[srcIdx + 0x14] then + mask <- mask ||| (1u <<< 0x14) + count <- count + 1 + + if f src.[srcIdx + 0x15] then + mask <- mask ||| (1u <<< 0x15) + count <- count + 1 + + if f src.[srcIdx + 0x16] then + mask <- mask ||| (1u <<< 0x16) + count <- count + 1 + + if f src.[srcIdx + 0x17] then + mask <- mask ||| (1u <<< 0x17) + count <- count + 1 + + if f src.[srcIdx + 0x18] then + mask <- mask ||| (1u <<< 0x18) + count <- count + 1 + + if f src.[srcIdx + 0x19] then + mask <- mask ||| (1u <<< 0x19) + count <- count + 1 + + if f src.[srcIdx + 0x1A] then + mask <- mask ||| (1u <<< 0x1A) + count <- count + 1 + + if f src.[srcIdx + 0x1B] then + mask <- mask ||| (1u <<< 0x1B) + count <- count + 1 + + if f src.[srcIdx + 0x1C] then + mask <- mask ||| (1u <<< 0x1C) + count <- count + 1 + + if f src.[srcIdx + 0x1D] then + mask <- mask ||| (1u <<< 0x1D) + count <- count + 1 + + if f src.[srcIdx + 0x1E] then + mask <- mask ||| (1u <<< 0x1E) + count <- count + 1 + + if f src.[srcIdx + 0x1F] then + mask <- mask ||| (1u <<< 0x1F) + count <- count + 1 + maskArray.[maskIdx] <- mask - count - let private createMask<'a> (f: 'a->bool) (src: array<'a>) (maskArrayOut: byref>) (leftoverMaskOut: byref) = + count + + let private createMask<'a> + (f: 'a -> bool) + (src: array<'a>) + (maskArrayOut: byref>) + (leftoverMaskOut: byref) + = let maskArrayLength = src.Length / 0x20 // null when there are less than 32 items in src array. let maskArray = - if maskArrayLength = 0 then Unchecked.defaultof<_> - else Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked maskArrayLength + if maskArrayLength = 0 then + Unchecked.defaultof<_> + else + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked maskArrayLength let mutable count = match maskArray with @@ -580,23 +853,30 @@ module Array = let leftoverMask = match src.Length % 0x20 with | 0 -> 0u - | _ -> + | _ -> let mutable mask = 0u let mutable elementMask = 1u - for arrayIdx = maskArrayLength*0x20 to src.Length-1 do - if f src.[arrayIdx] then mask <- mask ||| elementMask; count <- count + 1 + + for arrayIdx = maskArrayLength * 0x20 to src.Length - 1 do + if f src.[arrayIdx] then + mask <- mask ||| elementMask + count <- count + 1 + elementMask <- elementMask <<< 1 + mask - maskArrayOut <- maskArray + maskArrayOut <- maskArray leftoverMaskOut <- leftoverMask count - let private populateDstViaMask<'a> (src: array<'a>) (maskArray: array) (dst: array<'a>) = + let private populateDstViaMask<'a> (src: array<'a>) (maskArray: array) (dst: array<'a>) = let mutable dstIdx = 0 let mutable batchCount = 0 - for maskIdx = 0 to maskArray.Length-1 do + + for maskIdx = 0 to maskArray.Length - 1 do let mask = maskArray.[maskIdx] + if mask = 0xFFFFFFFFu then batchCount <- batchCount + 1 else @@ -604,48 +884,143 @@ module Array = if batchCount <> 0 then let batchSize = batchCount * 0x20 - System.Array.Copy (src, srcIdx-batchSize, dst, dstIdx, batchSize) + System.Array.Copy(src, srcIdx - batchSize, dst, dstIdx, batchSize) dstIdx <- dstIdx + batchSize batchCount <- 0 if mask <> 0u then - if mask &&& (1u <<< 0x00) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x00]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x01) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x01]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x02) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x02]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x03) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x03]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x04) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x04]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x05) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x05]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x06) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x06]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x07) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x07]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x08) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x08]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x09) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x09]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x0A) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x0A]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x0B) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x0B]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x0C) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x0C]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x0D) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x0D]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x0E) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x0E]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x0F) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x0F]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x10) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x10]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x11) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x11]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x12) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x12]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x13) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x13]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x14) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x14]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x15) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x15]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x16) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x16]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x17) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x17]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x18) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x18]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x19) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x19]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x1A) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x1A]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x1B) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x1B]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x1C) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x1C]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x1D) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x1D]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x1E) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x1E]; dstIdx <- dstIdx + 1 - if mask &&& (1u <<< 0x1F) <> 0u then dst.[dstIdx] <- src.[srcIdx+0x1F]; dstIdx <- dstIdx + 1 + if mask &&& (1u <<< 0x00) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x00] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x01) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x01] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x02) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x02] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x03) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x03] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x04) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x04] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x05) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x05] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x06) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x06] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x07) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x07] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x08) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x08] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x09) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x09] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x0A) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x0A] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x0B) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x0B] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x0C) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x0C] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x0D) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x0D] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x0E) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x0E] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x0F) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x0F] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x10) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x10] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x11) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x11] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x12) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x12] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x13) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x13] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x14) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x14] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x15) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x15] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x16) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x16] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x17) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x17] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x18) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x18] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x19) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x19] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x1A) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x1A] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x1B) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x1B] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x1C) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x1C] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x1D) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x1D] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x1E) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x1E] + dstIdx <- dstIdx + 1 + + if mask &&& (1u <<< 0x1F) <> 0u then + dst.[dstIdx] <- src.[srcIdx + 0x1F] + dstIdx <- dstIdx + 1 if batchCount <> 0 then let srcIdx = maskArray.Length * 0x20 let batchSize = batchCount * 0x20 - System.Array.Copy (src, srcIdx-batchSize, dst, dstIdx, batchSize) + System.Array.Copy(src, srcIdx - batchSize, dst, dstIdx, batchSize) dstIdx <- dstIdx + batchSize dstIdx @@ -654,34 +1029,41 @@ module Array = let dst = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count let mutable dstIdx = 0 + let srcIdx = match maskArray with | null -> 0 | _ -> dstIdx <- populateDstViaMask src maskArray dst - maskArray.Length*0x20 + maskArray.Length * 0x20 let mutable elementMask = 1u - for srcIdx = srcIdx to src.Length-1 do - if leftoverMask &&& elementMask <> 0u then dst.[dstIdx] <- src.[srcIdx]; dstIdx <- dstIdx + 1 + + for srcIdx = srcIdx to src.Length - 1 do + if leftoverMask &&& elementMask <> 0u then + dst.[dstIdx] <- src.[srcIdx] + dstIdx <- dstIdx + 1 + elementMask <- elementMask <<< 1 dst let filter f (src: array<_>) = - let mutable maskArray = Unchecked.defaultof<_> + let mutable maskArray = Unchecked.defaultof<_> let mutable leftOverMask = Unchecked.defaultof<_> + match createMask f src &maskArray &leftOverMask with - | 0 -> empty + | 0 -> empty | count -> filterViaMask maskArray leftOverMask count src [] - let filter predicate (array: _[]) = + let filter predicate (array: _[]) = checkNonNull "array" array Filter.filter predicate array - + [] - let where predicate (array: _[]) = filter predicate array + let where predicate (array: _[]) = + filter predicate array [] let except (itemsToExclude: seq<_>) (array: _[]) = @@ -695,49 +1077,68 @@ module Array = array |> filter cached.Add [] - let partition predicate (array: _[]) = + let partition predicate (array: _[]) = checkNonNull "array" array - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length let mutable upCount = 0 - let mutable downCount = array.Length-1 - for x in array do - if predicate x then + let mutable downCount = array.Length - 1 + + for x in array do + if predicate x then res.[upCount] <- x upCount <- upCount + 1 else res.[downCount] <- x downCount <- downCount - 1 - + let res1 = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 upCount res - let res2 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (array.Length - upCount) - - downCount <- array.Length-1 - for i = 0 to res2.Length-1 do + + let res2 = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (array.Length - upCount) + + downCount <- array.Length - 1 + + for i = 0 to res2.Length - 1 do res2.[i] <- res.[downCount] downCount <- downCount - 1 - + res1, res2 [] - let find predicate (array: _[]) = + let find predicate (array: _[]) = checkNonNull "array" array - let rec loop i = - if i >= array.Length then indexNotFound() else - if predicate array.[i] then array.[i] else loop (i+1) - loop 0 + + let rec loop i = + if i >= array.Length then + indexNotFound () + else if predicate array.[i] then + array.[i] + else + loop (i + 1) + + loop 0 [] - let tryFind predicate (array: _[]) = + let tryFind predicate (array: _[]) = checkNonNull "array" array - let rec loop i = - if i >= array.Length then None else - if predicate array.[i] then Some array.[i] else loop (i+1) - loop 0 + + let rec loop i = + if i >= array.Length then + None + else if predicate array.[i] then + Some array.[i] + else + loop (i + 1) + + loop 0 [] let skip count (array: 'T[]) = checkNonNull "array" array - if count > array.Length then invalidArgOutOfRange "count" count "array.Length" array.Length + + if count > array.Length then + invalidArgOutOfRange "count" count "array.Length" array.Length + if count = array.Length then empty else @@ -745,10 +1146,12 @@ module Array = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked count (array.Length - count) array [] - let skipWhile predicate (array: 'T[]) = + let skipWhile predicate (array: 'T[]) = checkNonNull "array" array - let mutable i = 0 - while i < array.Length && predicate array.[i] do i <- i + 1 + let mutable i = 0 + + while i < array.Length && predicate array.[i] do + i <- i + 1 match array.Length - i with | 0 -> empty @@ -777,61 +1180,94 @@ module Array = [] let windowed windowSize (array: 'T[]) = checkNonNull "array" array - if windowSize <= 0 then invalidArgInputMustBePositive "windowSize" windowSize + + if windowSize <= 0 then + invalidArgInputMustBePositive "windowSize" windowSize + let len = array.Length + if windowSize > len then empty else - let res: 'T[][] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len - windowSize + 1) + let res: 'T[][] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len - windowSize + 1) + for i = 0 to len - windowSize do res.[i] <- Microsoft.FSharp.Primitives.Basics.Array.subUnchecked i windowSize array + res [] let chunkBySize chunkSize (array: 'T[]) = checkNonNull "array" array - if chunkSize <= 0 then invalidArgInputMustBePositive "chunkSize" chunkSize + + if chunkSize <= 0 then + invalidArgInputMustBePositive "chunkSize" chunkSize + let len = array.Length + if len = 0 then empty else if chunkSize > len then [| copy array |] else let chunkCount = (len - 1) / chunkSize + 1 - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked chunkCount: 'T[][] + + let res: 'T[][] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked chunkCount + for i = 0 to len / chunkSize - 1 do res.[i] <- Microsoft.FSharp.Primitives.Basics.Array.subUnchecked (i * chunkSize) chunkSize array + if len % chunkSize <> 0 then - res.[chunkCount - 1] <- Microsoft.FSharp.Primitives.Basics.Array.subUnchecked ((chunkCount - 1) * chunkSize) (len % chunkSize) array + res.[chunkCount - 1] <- + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked + ((chunkCount - 1) * chunkSize) + (len % chunkSize) + array + res [] let splitInto count (array: _[]) = checkNonNull "array" array - if count <= 0 then invalidArgInputMustBePositive "count" count + + if count <= 0 then + invalidArgInputMustBePositive "count" count + Microsoft.FSharp.Primitives.Basics.Array.splitInto count array [] - let zip (array1: _[]) (array2: _[]) = + let zip (array1: _[]) (array2: _[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let len1 = array1.Length - if len1 <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len1 - for i = 0 to res.Length-1 do + let len1 = array1.Length + + if len1 <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len1 + + for i = 0 to res.Length - 1 do res.[i] <- (array1.[i], array2.[i]) + res [] - let zip3 (array1: _[]) (array2: _[]) (array3: _[]) = + let zip3 (array1: _[]) (array2: _[]) (array3: _[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 checkNonNull "array3" array3 let len1 = array1.Length - if len1 <> array2.Length || len1 <> array3.Length then invalidArg3ArraysDifferent "array1" "array2" "array3" len1 array2.Length array3.Length - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len1 - for i = 0 to res.Length-1 do + + if len1 <> array2.Length || len1 <> array3.Length then + invalidArg3ArraysDifferent "array1" "array2" "array3" len1 array2.Length array3.Length + + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len1 + + for i = 0 to res.Length - 1 do res.[i] <- (array1.[i], array2.[i], array3.[i]) + res [] @@ -841,179 +1277,218 @@ module Array = let len1 = array1.Length let len2 = array2.Length let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len1 * len2) - for i = 0 to array1.Length-1 do - for j = 0 to array2.Length-1 do + + for i = 0 to array1.Length - 1 do + for j = 0 to array2.Length - 1 do res.[i * len2 + j] <- (array1.[i], array2.[j]) + res [] - let unfold<'T, 'State> (generator: 'State -> ('T*'State) option) (state: 'State) = + let unfold<'T, 'State> (generator: 'State -> ('T * 'State) option) (state: 'State) = let res = ResizeArray<_>() + let rec loop state = match generator state with | None -> () | Some (x, s') -> res.Add(x) loop s' + loop state res.ToArray() [] - let unzip (array: _[]) = + let unzip (array: _[]) = checkNonNull "array" array - let len = array.Length - let res1 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - let res2 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - for i = 0 to array.Length-1 do - let x, y = array.[i] + let len = array.Length + let res1 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + let res2 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + + for i = 0 to array.Length - 1 do + let x, y = array.[i] res1.[i] <- x res2.[i] <- y + res1, res2 [] - let unzip3 (array: _[]) = - checkNonNull "array" array - let len = array.Length - let res1 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - let res2 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - let res3 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - for i = 0 to array.Length-1 do - let x, y, z = array.[i] + let unzip3 (array: _[]) = + checkNonNull "array" array + let len = array.Length + let res1 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + let res2 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + let res3 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + + for i = 0 to array.Length - 1 do + let x, y, z = array.[i] res1.[i] <- x res2.[i] <- y res3.[i] <- z + res1, res2, res3 [] - let rev (array: _[]) = + let rev (array: _[]) = checkNonNull "array" array let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length - let mutable j = array.Length-1 - for i = 0 to array.Length-1 do + let mutable j = array.Length - 1 + + for i = 0 to array.Length - 1 do res.[j] <- array.[i] j <- j - 1 + res [] let fold<'T, 'State> (folder: 'State -> 'T -> 'State) (state: 'State) (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (folder) let mutable state = state - for i = 0 to array.Length-1 do + + for i = 0 to array.Length - 1 do state <- f.Invoke(state, array.[i]) + state [] let foldBack<'T, 'State> (folder: 'T -> 'State -> 'State) (array: 'T[]) (state: 'State) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (folder) let mutable res = state - for i = array.Length-1 downto 0 do + + for i = array.Length - 1 downto 0 do res <- f.Invoke(array.[i], res) + res [] - let foldBack2<'T1, 'T2, 'State> folder (array1: 'T1[]) (array2: 'T2 []) (state: 'State) = + let foldBack2<'T1, 'T2, 'State> folder (array1: 'T1[]) (array2: 'T2[]) (state: 'State) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) - let mutable res = state + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (folder) + let mutable res = state let len = array1.Length - if len <> array2.Length then invalidArgDifferentArrayLength "array1" len "array2" array2.Length - for i = len-1 downto 0 do + + if len <> array2.Length then + invalidArgDifferentArrayLength "array1" len "array2" array2.Length + + for i = len - 1 downto 0 do res <- f.Invoke(array1.[i], array2.[i], res) + res [] - let fold2<'T1, 'T2, 'State> folder (state: 'State) (array1: 'T1[]) (array2: 'T2 []) = + let fold2<'T1, 'T2, 'State> folder (state: 'State) (array1: 'T1[]) (array2: 'T2[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) - let mutable state = state - if array1.Length <> array2.Length then invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length - for i = 0 to array1.Length-1 do + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (folder) + let mutable state = state + + if array1.Length <> array2.Length then + invalidArgDifferentArrayLength "array1" array1.Length "array2" array2.Length + + for i = 0 to array1.Length - 1 do state <- f.Invoke(state, array1.[i], array2.[i]) + state - let foldSubRight f (array: _[]) start fin acc = + let foldSubRight f (array: _[]) start fin acc = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) - let mutable res = acc + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (f) + let mutable res = acc + for i = fin downto start do res <- f.Invoke(array.[i], res) + res - let scanSubLeft f initState (array: _[]) start fin = + let scanSubLeft f initState (array: _[]) start fin = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) - let mutable state = initState - let res = create (2+fin-start) initState + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (f) + let mutable state = initState + let res = create (2 + fin - start) initState + for i = start to fin do state <- f.Invoke(state, array.[i]) - res.[i - start+1] <- state + res.[i - start + 1] <- state + res [] - let scan<'T, 'State> folder (state: 'State) (array: 'T[]) = + let scan<'T, 'State> folder (state: 'State) (array: 'T[]) = checkNonNull "array" array let len = array.Length scanSubLeft folder state array 0 (len - 1) [] - let scanBack<'T, 'State> folder (array: 'T[]) (state: 'State) = + let scanBack<'T, 'State> folder (array: 'T[]) (state: 'State) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.scanSubRight folder array 0 (array.Length - 1) state [] - let inline singleton value = [|value|] + let inline singleton value = + [| value |] [] let pairwise (array: 'T[]) = checkNonNull "array" array - if array.Length < 2 then empty else - init (array.Length-1) (fun i -> array.[i], array.[i+1]) + + if array.Length < 2 then + empty + else + init (array.Length - 1) (fun i -> array.[i], array.[i + 1]) [] - let reduce reduction (array: _[]) = + let reduce reduction (array: _[]) = checkNonNull "array" array let len = array.Length - if len = 0 then + + if len = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString - else - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(reduction) + else + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (reduction) let mutable res = array.[0] - for i = 1 to array.Length-1 do + + for i = 1 to array.Length - 1 do res <- f.Invoke(res, array.[i]) + res [] - let reduceBack reduction (array: _[]) = + let reduceBack reduction (array: _[]) = checkNonNull "array" array let len = array.Length - if len = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString - else foldSubRight reduction array 0 (len - 2) array.[len - 1] + + if len = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + else + foldSubRight reduction array 0 (len - 2) array.[len - 1] [] let sortInPlaceWith comparer (array: 'T[]) = checkNonNull "array" array - let len = array.Length - if len < 2 then () - elif len = 2 then - let c = comparer array.[0] array.[1] + let len = array.Length + + if len < 2 then + () + elif len = 2 then + let c = comparer array.[0] array.[1] + if c > 0 then - let tmp = array.[0] + let tmp = array.[0] array.[0] <- array.[1] array.[1] <- tmp - else + else Array.Sort(array, ComparisonIdentity.FromFunction(comparer)) [] - let sortInPlaceBy (projection: 'T -> 'U) (array: 'T[]) = + let sortInPlaceBy (projection: 'T -> 'U) (array: 'T[]) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.unstableSortInPlaceBy projection array [] - let sortInPlace (array: 'T[]) = + let sortInPlace (array: 'T[]) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.unstableSortInPlace array @@ -1032,7 +1507,7 @@ module Array = result [] - let sort array = + let sort array = checkNonNull "array" array let result = copy array sortInPlace result @@ -1041,144 +1516,189 @@ module Array = [] let inline sortByDescending projection array = checkNonNull "array" array - let inline compareDescending a b = compare (projection b) (projection a) + + let inline compareDescending a b = + compare (projection b) (projection a) + sortWith compareDescending array [] let inline sortDescending array = checkNonNull "array" array - let inline compareDescending a b = compare b a + + let inline compareDescending a b = + compare b a + sortWith compareDescending array [] - let toSeq array = + let toSeq array = checkNonNull "array" array Seq.ofArray array [] - let ofSeq source = + let ofSeq source = checkNonNull "source" source Seq.toArray source [] - let findIndex predicate (array: _[]) = - checkNonNull "array" array - let len = array.Length - let rec go n = - if n >= len then - indexNotFound() - elif predicate array.[n] then - n - else go (n+1) + let findIndex predicate (array: _[]) = + checkNonNull "array" array + let len = array.Length + + let rec go n = + if n >= len then indexNotFound () + elif predicate array.[n] then n + else go (n + 1) + go 0 [] - let tryFindIndex predicate (array: _[]) = + let tryFindIndex predicate (array: _[]) = checkNonNull "array" array - let len = array.Length - let rec go n = if n >= len then None elif predicate array.[n] then Some n else go (n+1) - go 0 + let len = array.Length + + let rec go n = + if n >= len then None + elif predicate array.[n] then Some n + else go (n + 1) + + go 0 [] - let permute indexMap (array: _[]) = + let permute indexMap (array: _[]) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.permute indexMap array [] - let inline sum (array: ^T[] ) : ^T = + let inline sum (array: ^T[]) : ^T = checkNonNull "array" array let mutable acc = LanguagePrimitives.GenericZero< ^T> + for i = 0 to array.Length - 1 do acc <- Checked.(+) acc array.[i] + acc [] - let inline sumBy ([] projection: 'T -> ^U) (array: 'T[]) : ^U = + let inline sumBy ([] projection: 'T -> ^U) (array: 'T[]) : ^U = checkNonNull "array" array let mutable acc = LanguagePrimitives.GenericZero< ^U> + for i = 0 to array.Length - 1 do acc <- Checked.(+) acc (projection array.[i]) + acc [] - let inline min (array: _[]) = + let inline min (array: _[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + let mutable acc = array.[0] + for i = 1 to array.Length - 1 do let curr = array.[i] - if curr < acc then - acc <- curr + if curr < acc then acc <- curr + acc [] - let inline minBy ([] projection) (array: _[]) = + let inline minBy ([] projection) (array: _[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + let mutable accv = array.[0] let mutable acc = projection accv + for i = 1 to array.Length - 1 do let currv = array.[i] let curr = projection currv + if curr < acc then acc <- curr accv <- currv + accv [] - let inline max (array: _[]) = + let inline max (array: _[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + let mutable acc = array.[0] + for i = 1 to array.Length - 1 do let curr = array.[i] - if curr > acc then - acc <- curr + if curr > acc then acc <- curr + acc [] - let inline maxBy projection (array: _[]) = + let inline maxBy projection (array: _[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + let mutable accv = array.[0] let mutable acc = projection accv + for i = 1 to array.Length - 1 do let currv = array.[i] let curr = projection currv + if curr > acc then acc <- curr accv <- currv + accv [] - let inline average (array: 'T[]) = + let inline average (array: 'T[]) = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + let mutable acc = LanguagePrimitives.GenericZero< ^T> + for i = 0 to array.Length - 1 do acc <- Checked.(+) acc array.[i] + LanguagePrimitives.DivideByInt< ^T> acc array.Length [] - let inline averageBy ([] projection: 'T -> ^U) (array: 'T[]) : ^U = + let inline averageBy ([] projection: 'T -> ^U) (array: 'T[]) : ^U = checkNonNull "array" array - if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + + if array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString + let mutable acc = LanguagePrimitives.GenericZero< ^U> + for i = 0 to array.Length - 1 do acc <- Checked.(+) acc (projection array.[i]) + LanguagePrimitives.DivideByInt< ^U> acc array.Length [] - let inline compareWith ([] comparer: 'T -> 'T -> int) (array1: 'T[]) (array2: 'T[]) = + let inline compareWith ([] comparer: 'T -> 'T -> int) (array1: 'T[]) (array2: 'T[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 let length1 = array1.Length let length2 = array2.Length - + let mutable i = 0 let mutable result = 0 - + if length1 < length2 then while i < array1.Length && result = 0 do result <- comparer array1.[i] array2.[i] @@ -1196,9 +1716,16 @@ module Array = [] let sub (array: 'T[]) (startIndex: int) (count: int) = checkNonNull "array" array - if startIndex < 0 then invalidArgInputMustBeNonNegative "startIndex" startIndex - if count < 0 then invalidArgInputMustBeNonNegative "count" count - if startIndex + count > array.Length then invalidArgOutOfRange "count" count "array.Length" array.Length + + if startIndex < 0 then + invalidArgInputMustBeNonNegative "startIndex" startIndex + + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + + if startIndex + count > array.Length then + invalidArgOutOfRange "count" count "array.Length" array.Length + Microsoft.FSharp.Primitives.Basics.Array.subUnchecked startIndex count array [] @@ -1208,57 +1735,84 @@ module Array = [] let tryItem index (array: 'T[]) = checkNonNull "array" array - if index < 0 || index >= array.Length then None - else Some(array.[index]) + + if index < 0 || index >= array.Length then + None + else + Some(array.[index]) [] - let get (array: _[]) index = + let get (array: _[]) index = array.[index] [] - let set (array: _[]) index value = + let set (array: _[]) index value = array.[index] <- value [] let fill (target: 'T[]) (targetIndex: int) (count: int) (value: 'T) = checkNonNull "target" target - if targetIndex < 0 then invalidArgInputMustBeNonNegative "targetIndex" targetIndex - if count < 0 then invalidArgInputMustBeNonNegative "count" count - for i = targetIndex to targetIndex + count - 1 do + + if targetIndex < 0 then + invalidArgInputMustBeNonNegative "targetIndex" targetIndex + + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + + for i = targetIndex to targetIndex + count - 1 do target.[i] <- value [] let exactlyOne (array: 'T[]) = checkNonNull "array" array - if array.Length = 1 then array.[0] - elif array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - else invalidArg "array" (SR.GetString(SR.inputSequenceTooLong)) + + if array.Length = 1 then + array.[0] + elif array.Length = 0 then + invalidArg "array" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + else + invalidArg "array" (SR.GetString(SR.inputSequenceTooLong)) [] let tryExactlyOne (array: 'T[]) = checkNonNull "array" array - if array.Length = 1 then Some array.[0] - else None + + if array.Length = 1 then + Some array.[0] + else + None let transposeArrays (array: 'T[][]) = let len = array.Length - if len = 0 then Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 else - let lenInner = array.[0].Length - - for j in 1..len-1 do - if lenInner <> array.[j].Length then - invalidArgDifferentArrayLength "array.[0]" lenInner (String.Format("array.[{0}]", j)) array.[j].Length - - let result: 'T[][] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked lenInner - for i in 0..lenInner-1 do - result.[i] <- Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - for j in 0..len-1 do - result.[i].[j] <- array.[j].[i] - result + + if len = 0 then + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 + else + let lenInner = array.[0].Length + + for j in 1 .. len - 1 do + if lenInner <> array.[j].Length then + invalidArgDifferentArrayLength + "array.[0]" + lenInner + (String.Format("array.[{0}]", j)) + array.[j].Length + + let result: 'T[][] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked lenInner + + for i in 0 .. lenInner - 1 do + result.[i] <- Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + + for j in 0 .. len - 1 do + result.[i].[j] <- array.[j].[i] + + result [] let transpose (arrays: seq<'T[]>) = checkNonNull "arrays" arrays + match arrays with | :? ('T[][]) as ts -> ts |> transposeArrays // avoid a clone, since we only read the array | _ -> arrays |> Seq.toArray |> transposeArrays @@ -1266,7 +1820,9 @@ module Array = [] let truncate count (array: 'T[]) = checkNonNull "array" array - if count <= 0 then empty + + if count <= 0 then + empty else let len = array.Length let count' = Operators.min count len @@ -1275,186 +1831,234 @@ module Array = [] let removeAt (index: int) (source: 'T[]) : 'T[] = checkNonNull "source" source - if index < 0 || index >= source.Length then invalidArg "index" "index must be within bounds of the array" - + + if index < 0 || index >= source.Length then + invalidArg "index" "index must be within bounds of the array" + let length = source.Length - 1 let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked length - if index > 0 then + + if index > 0 then Array.Copy(source, result, index) + if length - index > 0 then Array.Copy(source, index + 1, result, index, length - index) - + result - + [] let removeManyAt (index: int) (count: int) (source: 'T[]) : 'T[] = checkNonNull "source" source - if index < 0 || index > source.Length - count then invalidArg "index" "index must be within bounds of the array" - + + if index < 0 || index > source.Length - count then + invalidArg "index" "index must be within bounds of the array" + let length = source.Length - count let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked length if index > 0 then Array.Copy(source, result, index) + if length - index > 0 then Array.Copy(source, index + count, result, index, length - index) - + result - + [] let updateAt (index: int) (value: 'T) (source: 'T[]) : 'T[] = checkNonNull "source" source - if index < 0 || index >= source.Length then invalidArg "index" "index must be within bounds of the array" - + + if index < 0 || index >= source.Length then + invalidArg "index" "index must be within bounds of the array" + let length = source.Length let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked length if length > 0 then Array.Copy(source, result, length) + result.[index] <- value - + result - + [] let insertAt (index: int) (value: 'T) (source: 'T[]) : 'T[] = checkNonNull "source" source - if index < 0 || index > source.Length then invalidArg "index" "index must be within bounds of the array" - + + if index < 0 || index > source.Length then + invalidArg "index" "index must be within bounds of the array" + let length = source.Length + 1 let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked length if index > 0 then Array.Copy(source, result, index) - + result.[index] <- value - + if source.Length - index > 0 then Array.Copy(source, index, result, index + 1, source.Length - index) - + result - + [] let insertManyAt (index: int) (values: seq<'T>) (source: 'T[]) : 'T[] = checkNonNull "source" source - if index < 0 || index > source.Length then invalidArg "index" "index must be within bounds of the array" - + + if index < 0 || index > source.Length then + invalidArg "index" "index must be within bounds of the array" + let valuesArray = Seq.toArray values - if valuesArray.Length = 0 then source + + if valuesArray.Length = 0 then + source else let length = source.Length + valuesArray.Length let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked length - + if index > 0 then Array.Copy(source, result, index) - + Array.Copy(valuesArray, 0, result, index, valuesArray.Length) - + if source.Length - index > 0 then Array.Copy(source, index, result, index + valuesArray.Length, source.Length - index) - + result module Parallel = open System.Threading.Tasks - + [] - let choose chooser (array: 'T[]) = + let choose chooser (array: 'T[]) = checkNonNull "array" array let inputLength = array.Length - let isChosen: bool [] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength - let results: 'U [] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength - let mutable outputLength = 0 - Parallel.For(0, - inputLength, - (fun () ->0), - (fun i _ count -> - match chooser array.[i] with - | None -> count - | Some v -> - isChosen.[i] <- true; - results.[i] <- v - count+1), - Action (fun x -> System.Threading.Interlocked.Add(&outputLength, x) |> ignore ) - ) |> ignore - - let output = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked outputLength + let isChosen: bool[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + + let results: 'U[] = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + + let mutable outputLength = 0 + + Parallel.For( + 0, + inputLength, + (fun () -> 0), + (fun i _ count -> + match chooser array.[i] with + | None -> count + | Some v -> + isChosen.[i] <- true + results.[i] <- v + count + 1), + Action(fun x -> System.Threading.Interlocked.Add(&outputLength, x) |> ignore) + ) + |> ignore + + let output = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked outputLength + let mutable curr = 0 - for i = 0 to isChosen.Length-1 do - if isChosen.[i] then + + for i = 0 to isChosen.Length - 1 do + if isChosen.[i] then output.[curr] <- results.[i] curr <- curr + 1 + output - + [] - let collect (mapping: 'T -> 'U[]) (array: 'T[]) : 'U[]= + let collect (mapping: 'T -> 'U[]) (array: 'T[]) : 'U[] = checkNonNull "array" array let inputLength = array.Length - let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength - Parallel.For(0, inputLength, - (fun i -> result.[i] <- mapping array.[i])) |> ignore + + let result = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + + Parallel.For(0, inputLength, (fun i -> result.[i] <- mapping array.[i])) + |> ignore + concatArrays result - + [] - let map (mapping: 'T -> 'U) (array: 'T[]) : 'U[]= + let map (mapping: 'T -> 'U) (array: 'T[]) : 'U[] = checkNonNull "array" array let inputLength = array.Length - let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength - Parallel.For(0, inputLength, fun i -> - result.[i] <- mapping array.[i]) |> ignore + + let result = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + + Parallel.For(0, inputLength, (fun i -> result.[i] <- mapping array.[i])) + |> ignore + result - + [] let mapi mapping (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (mapping) let inputLength = array.Length - let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength - Parallel.For(0, inputLength, fun i -> - result.[i] <- f.Invoke (i, array.[i])) |> ignore + + let result = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + + Parallel.For(0, inputLength, (fun i -> result.[i] <- f.Invoke(i, array.[i]))) + |> ignore + result - + [] let iter action (array: 'T[]) = checkNonNull "array" array - Parallel.For (0, array.Length, fun i -> action array.[i]) |> ignore - + Parallel.For(0, array.Length, (fun i -> action array.[i])) |> ignore + [] let iteri action (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) - Parallel.For (0, array.Length, fun i -> f.Invoke(i, array.[i])) |> ignore - + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (action) + Parallel.For(0, array.Length, (fun i -> f.Invoke(i, array.[i]))) |> ignore + [] let init count initializer = let result = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count - Parallel.For (0, count, fun i -> result.[i] <- initializer i) |> ignore + Parallel.For(0, count, (fun i -> result.[i] <- initializer i)) |> ignore result - + [] let partition predicate (array: 'T[]) = checkNonNull "array" array let inputLength = array.Length - - let isTrue = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + + let isTrue = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked inputLength + let mutable trueLength = 0 - Parallel.For(0, - inputLength, - (fun () -> 0), - (fun i _ trueCount -> - if predicate array.[i] then - isTrue.[i] <- true - trueCount + 1 - else - trueCount), - Action (fun x -> System.Threading.Interlocked.Add(&trueLength, x) |> ignore) ) |> ignore - + + Parallel.For( + 0, + inputLength, + (fun () -> 0), + (fun i _ trueCount -> + if predicate array.[i] then + isTrue.[i] <- true + trueCount + 1 + else + trueCount), + Action(fun x -> System.Threading.Interlocked.Add(&trueLength, x) |> ignore) + ) + |> ignore + let res1 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked trueLength - let res2 = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (inputLength - trueLength) + + let res2 = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (inputLength - trueLength) let mutable iTrue = 0 let mutable iFalse = 0 - for i = 0 to isTrue.Length-1 do + + for i = 0 to isTrue.Length - 1 do if isTrue.[i] then res1.[iTrue] <- array.[i] iTrue <- iTrue + 1 @@ -1462,4 +2066,4 @@ module Array = res2.[iFalse] <- array.[i] iFalse <- iFalse + 1 - res1, res2 \ No newline at end of file + res1, res2 diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index 0b64a6450d1..46cd93a84ee 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -21,18 +21,21 @@ type LinkedSubSource(cancellationToken: CancellationToken) = let failureCTS = new CancellationTokenSource() - let linkedCTS = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, failureCTS.Token) + let linkedCTS = + CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, failureCTS.Token) member _.Token = linkedCTS.Token - member _.Cancel() = failureCTS.Cancel() + member _.Cancel() = + failureCTS.Cancel() member _.Dispose() = linkedCTS.Dispose() failureCTS.Dispose() interface IDisposable with - member this.Dispose() = this.Dispose() + member this.Dispose() = + this.Dispose() /// Global mutable state used to associate Exception [] @@ -45,7 +48,11 @@ module ExceptionDispatchInfoHelpers = member edi.GetAssociatedSourceException() = let exn = edi.SourceException // Try to store the entry in the association table to allow us to recover it later. - try associationTable.Add(exn, edi) with _ -> () + try + associationTable.Add(exn, edi) + with _ -> + () + exn // Capture, but prefer the saved information if available @@ -53,8 +60,7 @@ module ExceptionDispatchInfoHelpers = static member RestoreOrCapture exn = match associationTable.TryGetValue exn with | true, edi -> edi - | _ -> - ExceptionDispatchInfo.Capture exn + | _ -> ExceptionDispatchInfo.Capture exn member inline edi.ThrowAny() = edi.Throw() @@ -66,8 +72,9 @@ module ExceptionDispatchInfoHelpers = [] type AsyncReturn = | AsyncReturn - with - static member inline Fake() = Unchecked.defaultof + + static member inline Fake() = + Unchecked.defaultof type cont<'T> = ('T -> AsyncReturn) type econt = (ExceptionDispatchInfo -> AsyncReturn) @@ -82,8 +89,7 @@ type Trampoline() = [] static val mutable private thisThreadHasTrampoline: bool - static member ThisThreadHasTrampoline = - Trampoline.thisThreadHasTrampoline + static member ThisThreadHasTrampoline = Trampoline.thisThreadHasTrampoline let mutable storedCont = None let mutable storedExnCont = None @@ -92,26 +98,28 @@ type Trampoline() = /// Use this trampoline on the synchronous stack if none exists, and execute /// the given function. The function might write its continuation into the trampoline. [] - member _.Execute (firstAction: unit -> AsyncReturn) = + member _.Execute(firstAction: unit -> AsyncReturn) = let thisThreadHadTrampoline = Trampoline.thisThreadHasTrampoline Trampoline.thisThreadHasTrampoline <- true + try let mutable keepGoing = true let mutable action = firstAction + while keepGoing do try - action() |> ignore + action () |> ignore + match storedCont with - | None -> - keepGoing <- false + | None -> keepGoing <- false | Some cont -> storedCont <- None action <- cont - + // Catch exceptions at the trampoline to get a full .StackTrace entry // This is because of this problem https://stackoverflow.com/questions/5301535/exception-call-stack-truncated-without-any-re-throwing - // where only a limited number of stack frames are included in the .StackTrace property + // where only a limited number of stack frames are included in the .StackTrace property // of a .NET exception when it is thrown, up to the first catch handler. // // So when running async code, there aren't any intermediate catch handlers (though there @@ -127,7 +135,7 @@ type Trampoline() = // direct uses of combinators (not using async {...}) may cause // code to execute unprotected, e.g. async.While((fun () -> failwith ".."), ...) executes the first // guardExpr unprotected. - reraise() + reraise () | Some econt -> storedExnCont <- None @@ -136,6 +144,7 @@ type Trampoline() = finally Trampoline.thisThreadHasTrampoline <- thisThreadHadTrampoline + AsyncReturn.Fake() /// Increment the counter estimating the size of the synchronous stack and @@ -152,7 +161,7 @@ type Trampoline() = AsyncReturn.Fake() /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member _.OnExceptionRaised (action: econt) = + member _.OnExceptionRaised(action: econt) = assert storedExnCont.IsNone storedExnCont <- Some action @@ -160,40 +169,47 @@ type TrampolineHolder() = let mutable trampoline = null // On-demand allocate this delegate and keep it in the trampoline holder. - let mutable sendOrPostCallbackWithTrampoline : SendOrPostCallback = null - let getSendOrPostCallbackWithTrampoline(this: TrampolineHolder) = - match sendOrPostCallbackWithTrampoline with + let mutable sendOrPostCallbackWithTrampoline: SendOrPostCallback = null + + let getSendOrPostCallbackWithTrampoline (this: TrampolineHolder) = + match sendOrPostCallbackWithTrampoline with | null -> - sendOrPostCallbackWithTrampoline <- - SendOrPostCallback (fun o -> - let f = unbox AsyncReturn> o - // Reminder: the ignore below ignores an AsyncReturn. - this.ExecuteWithTrampoline f |> ignore) + sendOrPostCallbackWithTrampoline <- + SendOrPostCallback(fun o -> + let f = unbox AsyncReturn> o + // Reminder: the ignore below ignores an AsyncReturn. + this.ExecuteWithTrampoline f |> ignore) | _ -> () + sendOrPostCallbackWithTrampoline // On-demand allocate this delegate and keep it in the trampoline holder. - let mutable waitCallbackForQueueWorkItemWithTrampoline : WaitCallback = null - let getWaitCallbackForQueueWorkItemWithTrampoline(this: TrampolineHolder) = - match waitCallbackForQueueWorkItemWithTrampoline with + let mutable waitCallbackForQueueWorkItemWithTrampoline: WaitCallback = null + + let getWaitCallbackForQueueWorkItemWithTrampoline (this: TrampolineHolder) = + match waitCallbackForQueueWorkItemWithTrampoline with | null -> waitCallbackForQueueWorkItemWithTrampoline <- - WaitCallback (fun o -> + WaitCallback(fun o -> let f = unbox AsyncReturn> o this.ExecuteWithTrampoline f |> ignore) | _ -> () + waitCallbackForQueueWorkItemWithTrampoline // On-demand allocate this delegate and keep it in the trampoline holder. - let mutable threadStartCallbackForStartThreadWithTrampoline : ParameterizedThreadStart = null - let getThreadStartCallbackForStartThreadWithTrampoline(this: TrampolineHolder) = - match threadStartCallbackForStartThreadWithTrampoline with + let mutable threadStartCallbackForStartThreadWithTrampoline: ParameterizedThreadStart = + null + + let getThreadStartCallbackForStartThreadWithTrampoline (this: TrampolineHolder) = + match threadStartCallbackForStartThreadWithTrampoline with | null -> threadStartCallbackForStartThreadWithTrampoline <- - ParameterizedThreadStart (fun o -> + ParameterizedThreadStart(fun o -> let f = unbox AsyncReturn> o this.ExecuteWithTrampoline f |> ignore) | _ -> () + threadStartCallbackForStartThreadWithTrampoline /// Execute an async computation after installing a trampoline on its synchronous stack. @@ -202,13 +218,14 @@ type TrampolineHolder() = trampoline <- Trampoline() trampoline.Execute firstAction - member this.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = - syncCtxt.Post (getSendOrPostCallbackWithTrampoline(this), state=(f |> box)) + member this.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = + syncCtxt.Post(getSendOrPostCallbackWithTrampoline (this), state = (f |> box)) AsyncReturn.Fake() - member this.QueueWorkItemWithTrampoline (f: unit -> AsyncReturn) = - if not (ThreadPool.QueueUserWorkItem(getWaitCallbackForQueueWorkItemWithTrampoline(this), f |> box)) then + member this.QueueWorkItemWithTrampoline(f: unit -> AsyncReturn) = + if not (ThreadPool.QueueUserWorkItem(getWaitCallbackForQueueWorkItemWithTrampoline (this), f |> box)) then failwith "failed to queue user work item" + AsyncReturn.Fake() member this.PostOrQueueWithTrampoline (syncCtxt: SynchronizationContext) f = @@ -217,8 +234,10 @@ type TrampolineHolder() = | _ -> this.PostWithTrampoline syncCtxt f // This should be the only call to Thread.Start in this library. We must always install a trampoline. - member this.StartThreadWithTrampoline (f: unit -> AsyncReturn) = - Thread(getThreadStartCallbackForStartThreadWithTrampoline(this), IsBackground=true).Start(f|>box) + member this.StartThreadWithTrampoline(f: unit -> AsyncReturn) = + Thread(getThreadStartCallbackForStartThreadWithTrampoline (this), IsBackground = true) + .Start(f |> box) + AsyncReturn.Fake() /// Save the exception continuation during propagation of an exception, or prior to raising an exception @@ -228,7 +247,7 @@ type TrampolineHolder() = /// Call a continuation, but first check if an async computation should trampoline on its synchronous stack. member inline _.HijackCheckThenCall (cont: 'T -> AsyncReturn) res = if trampoline.IncrementBindCount() then - trampoline.Set (fun () -> cont res) + trampoline.Set(fun () -> cont res) else // NOTE: this must be a tailcall cont res @@ -237,27 +256,31 @@ type TrampolineHolder() = [] [] type AsyncActivationAux = - { /// The active cancellation token - token: CancellationToken + { + /// The active cancellation token + token: CancellationToken - /// The exception continuation - econt: econt + /// The exception continuation + econt: econt - /// The cancellation continuation - ccont: ccont + /// The cancellation continuation + ccont: ccont - /// Holds some commonly-allocated callbacks and a mutable location to use for a trampoline - trampolineHolder: TrampolineHolder } + /// Holds some commonly-allocated callbacks and a mutable location to use for a trampoline + trampolineHolder: TrampolineHolder + } /// Represents context for an in-flight async computation [] [] type AsyncActivationContents<'T> = - { /// The success continuation - cont: cont<'T> + { + /// The success continuation + cont: cont<'T> - /// The rarely changing components - aux: AsyncActivationAux } + /// The rarely changing components + aux: AsyncActivationAux + } /// A struct wrapper around AsyncActivationContents. Using a struct wrapper allows us to change representation of the /// contents at a later point, e.g. to change the contents to a .NET Task or some other representation. @@ -265,19 +288,42 @@ type AsyncActivationContents<'T> = type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = /// Produce a new execution context for a composite async - member ctxt.WithCancellationContinuation ccont = AsyncActivation<'T> { contents with aux = { ctxt.aux with ccont = ccont } } + member ctxt.WithCancellationContinuation ccont = + AsyncActivation<'T> + { contents with + aux = { ctxt.aux with ccont = ccont } + } /// Produce a new execution context for a composite async - member ctxt.WithExceptionContinuation econt = AsyncActivation<'T> { contents with aux = { ctxt.aux with econt = econt } } + member ctxt.WithExceptionContinuation econt = + AsyncActivation<'T> + { contents with + aux = { ctxt.aux with econt = econt } + } /// Produce a new execution context for a composite async - member _.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } + member _.WithContinuation cont = + AsyncActivation<'U> { cont = cont; aux = contents.aux } /// Produce a new execution context for a composite async - member _.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } + member _.WithContinuations(cont, econt) = + AsyncActivation<'U> + { + cont = cont + aux = { contents.aux with econt = econt } + } /// Produce a new execution context for a composite async - member ctxt.WithContinuations(cont, econt, ccont) = AsyncActivation<'T> { contents with cont = cont; aux = { ctxt.aux with econt = econt; ccont = ccont } } + member ctxt.WithContinuations(cont, econt, ccont) = + AsyncActivation<'T> + { contents with + cont = cont + aux = + { ctxt.aux with + econt = econt + ccont = ccont + } + } /// The extra information relevant to the execution of the async member _.aux = contents.aux @@ -301,8 +347,8 @@ type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = member _.IsCancellationRequested = contents.aux.token.IsCancellationRequested /// Call the cancellation continuation of the active computation - member _.OnCancellation () = - contents.aux.ccont (OperationCanceledException (contents.aux.token)) + member _.OnCancellation() = + contents.aux.ccont (OperationCanceledException(contents.aux.token)) /// Check for trampoline hijacking. // @@ -319,13 +365,14 @@ type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = // Note, this must make tailcalls, so may not be an instance member taking a byref argument. static member Success (ctxt: AsyncActivation<'T>) result = if ctxt.IsCancellationRequested then - ctxt.OnCancellation () + ctxt.OnCancellation() else AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.cont result // For backwards API Compat [] - member ctxt.OnSuccess (result: 'T) = AsyncActivation<'T>.Success ctxt result + member ctxt.OnSuccess(result: 'T) = + AsyncActivation<'T>.Success ctxt result /// Save the exception continuation during propagation of an exception, or prior to raising an exception member _.OnExceptionRaised() = @@ -333,11 +380,21 @@ type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = /// Make an initial async activation. static member Create cancellationToken trampolineHolder cont econt ccont : AsyncActivation<'T> = - AsyncActivation { cont = cont; aux = { token = cancellationToken; econt = econt; ccont = ccont; trampolineHolder = trampolineHolder } } + AsyncActivation + { + cont = cont + aux = + { + token = cancellationToken + econt = econt + ccont = ccont + trampolineHolder = trampolineHolder + } + } /// Queue the success continuation of the asynchronous execution context as a work item in the thread pool /// after installing a trampoline - member ctxt.QueueContinuationWithTrampoline (result: 'T) = + member ctxt.QueueContinuationWithTrampoline(result: 'T) = let cont = ctxt.cont ctxt.aux.trampolineHolder.QueueWorkItemWithTrampoline(fun () -> cont result) @@ -349,17 +406,17 @@ type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = [] member ctxt.ProtectCode userCode = let mutable ok = false + try - let res = userCode() + let res = userCode () ok <- true res finally - if not ok then - ctxt.OnExceptionRaised() + if not ok then ctxt.OnExceptionRaised() - member ctxt.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = + member ctxt.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = let holder = contents.aux.trampolineHolder - ctxt.ProtectCode (fun () -> holder.PostWithTrampoline syncCtxt f) + ctxt.ProtectCode(fun () -> holder.PostWithTrampoline syncCtxt f) /// Call the success continuation of the asynchronous execution context member ctxt.CallContinuation(result: 'T) = @@ -368,7 +425,9 @@ type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = /// Represents an asynchronous computation [] type Async<'T> = - { Invoke: (AsyncActivation<'T> -> AsyncReturn) } + { + Invoke: (AsyncActivation<'T> -> AsyncReturn) + } /// Mutable register to help ensure that code is only executed once [] @@ -376,18 +435,19 @@ type Latch() = let mutable i = 0 /// Execute the latch - member _.Enter() = Interlocked.CompareExchange(&i, 1, 0) = 0 + member _.Enter() = + Interlocked.CompareExchange(&i, 1, 0) = 0 /// Represents the result of an asynchronous computation [] -type AsyncResult<'T> = +type AsyncResult<'T> = | Ok of 'T | Error of ExceptionDispatchInfo | Canceled of OperationCanceledException /// Get the result of an asynchronous computation [] - member res.Commit () = + member res.Commit() = match res with | AsyncResult.Ok res -> res | AsyncResult.Error edi -> edi.ThrowAny() @@ -396,9 +456,11 @@ type AsyncResult<'T> = /// Primitives to execute asynchronous computations module AsyncPrimitives = - let inline fake () = Unchecked.defaultof + let inline fake () = + Unchecked.defaultof - let inline unfake (_: AsyncReturn) = () + let inline unfake (_: AsyncReturn) = + () /// The mutable global CancellationTokenSource, see Async.DefaultCancellationToken let mutable defaultCancellationTokenSource = new CancellationTokenSource() @@ -424,13 +486,12 @@ module AsyncPrimitives = result <- userCode arg ok <- true finally - if not ok then - ctxt.OnExceptionRaised() + if not ok then ctxt.OnExceptionRaised() if ok then AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.cont result else - fake() + fake () /// Apply 'part2' to 'result1' and invoke the resulting computation. /// @@ -447,13 +508,12 @@ module AsyncPrimitives = result <- part2 result1 ok <- true finally - if not ok then - ctxt.OnExceptionRaised() + if not ok then ctxt.OnExceptionRaised() if ok then Invoke result ctxt else - fake() + fake () /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) [] @@ -465,13 +525,9 @@ module AsyncPrimitives = res <- userCode result1 ok <- true finally - if not ok then - ctxt.OnExceptionRaised() + if not ok then ctxt.OnExceptionRaised() - if ok then - res.Invoke ctxt - else - fake() + if ok then res.Invoke ctxt else fake () /// Apply 'filterFunction' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' /// then send 'result1' to the exception continuation. @@ -487,32 +543,30 @@ module AsyncPrimitives = resOpt <- filterFunction (edi.GetAssociatedSourceException()) ok <- true finally - if not ok then - ctxt.OnExceptionRaised() + if not ok then ctxt.OnExceptionRaised() if ok then match resOpt with - | None -> - AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.econt edi - | Some res -> - Invoke res ctxt + | None -> AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.econt edi + | Some res -> Invoke res ctxt else - fake() + fake () /// Build a primitive without any exception or resync protection [] - let MakeAsync body = { Invoke = body } + let MakeAsync body = + { Invoke = body } [] let MakeAsyncWithCancelCheck body = - MakeAsync (fun ctxt -> + MakeAsync(fun ctxt -> if ctxt.IsCancellationRequested then - ctxt.OnCancellation () + ctxt.OnCancellation() else body ctxt) /// Execute part1, then apply part2, then execute the result of that - /// + /// /// Note: direct calls to this function end up in user assemblies via inlining /// - Initial cancellation check /// - Initial hijack check (see Invoke) @@ -522,7 +576,7 @@ module AsyncPrimitives = [] let Bind (ctxt: AsyncActivation<'T>) (part1: Async<'U>) (part2: 'U -> Async<'T>) : AsyncReturn = if ctxt.IsCancellationRequested then - ctxt.OnCancellation () + ctxt.OnCancellation() else // Note, no cancellation check is done before calling 'part2'. This is // because part1 may bind a resource, while part2 is a try/finally, and, if @@ -552,11 +606,15 @@ module AsyncPrimitives = // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) let ccont cexn = - CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) + CallThenContinue + finallyFunction + () + (ctxt.WithContinuations(cont = (fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) + + let ctxt = ctxt.WithContinuations(cont = cont, econt = econt, ccont = ccont) - let ctxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) if ctxt.IsCancellationRequested then - ctxt.OnCancellation () + ctxt.OnCancellation() else computation.Invoke ctxt @@ -570,12 +628,12 @@ module AsyncPrimitives = [] let TryWith (ctxt: AsyncActivation<'T>) (computation: Async<'T>) catchFunction = if ctxt.IsCancellationRequested then - ctxt.OnCancellation () + ctxt.OnCancellation() else let ctxt = ctxt.WithExceptionContinuation(fun edi -> if ctxt.IsCancellationRequested then - ctxt.OnCancellation () + ctxt.OnCancellation() else CallFilterThenInvoke ctxt catchFunction edi) @@ -585,7 +643,7 @@ module AsyncPrimitives = // - No cancellation check // - No hijack check let CreateAsyncResultAsync res = - MakeAsync (fun ctxt -> + MakeAsync(fun ctxt -> match res with | AsyncResult.Ok r -> ctxt.cont r | AsyncResult.Error edi -> ctxt.econt edi @@ -596,7 +654,7 @@ module AsyncPrimitives = /// - Hijack check (see OnSuccess) let inline CreateReturnAsync res = // Note: this code ends up in user assemblies via inlining - MakeAsync (fun ctxt -> AsyncActivation.Success ctxt res) + MakeAsync(fun ctxt -> AsyncActivation.Success ctxt res) /// Runs the first process, takes its result, applies f and then runs the new process produced. /// - Initial cancellation check (see Bind) @@ -604,18 +662,16 @@ module AsyncPrimitives = /// - No hijack check after applying 'part2' to argument (see Bind) /// - No cancellation check after applying 'part2' to argument (see Bind) /// - Apply 'part2' to argument with exception protection (see Bind) - let inline CreateBindAsync part1 part2 = + let inline CreateBindAsync part1 part2 = // Note: this code ends up in user assemblies via inlining - MakeAsync (fun ctxt -> - Bind ctxt part1 part2) + MakeAsync(fun ctxt -> Bind ctxt part1 part2) /// Call the given function with exception protection. /// - No initial cancellation check /// - Hijack check after applying part2 to argument (see CallThenInvoke) let inline CreateCallAsync part2 result1 = // Note: this code ends up in user assemblies via inlining - MakeAsync (fun ctxt -> - CallThenInvoke ctxt result1 part2) + MakeAsync(fun ctxt -> CallThenInvoke ctxt result1 part2) /// Call the given function with exception protection. /// - Initial cancellation check @@ -623,8 +679,7 @@ module AsyncPrimitives = /// - Apply 'computation' to argument with exception protection (see CallThenInvoke) let inline CreateDelayAsync computation = // Note: this code ends up in user assemblies via inlining - MakeAsyncWithCancelCheck (fun ctxt -> - CallThenInvoke ctxt () computation) + MakeAsyncWithCancelCheck(fun ctxt -> CallThenInvoke ctxt () computation) /// Implements the sequencing construct of async computation expressions /// - Initial cancellation check (see CreateBindAsync) @@ -641,7 +696,7 @@ module AsyncPrimitives = /// - Hijack check after 'entering' the try/finally and before running the body (see TryFinally) /// - Apply 'finallyFunction' with exception protection (see TryFinally) let inline CreateTryFinallyAsync finallyFunction computation = - MakeAsync (fun ctxt -> TryFinally ctxt computation finallyFunction) + MakeAsync(fun ctxt -> TryFinally ctxt computation finallyFunction) /// Create an async for a try/with filtering exceptions through a pattern match /// - Cancellation check before entering the try (see TryWith) @@ -649,7 +704,7 @@ module AsyncPrimitives = /// - Apply `filterFunction' to argument with exception protection (see TryWith) /// - Hijack check before invoking the resulting computation or exception continuation let inline CreateTryWithFilterAsync filterFunction computation = - MakeAsync (fun ctxt -> TryWith ctxt computation filterFunction) + MakeAsync(fun ctxt -> TryWith ctxt computation filterFunction) /// Create an async for a try/with filtering /// - Cancellation check before entering the try (see TryWith) @@ -657,7 +712,7 @@ module AsyncPrimitives = /// - Apply `catchFunction' to argument with exception protection (see TryWith) /// - Hijack check before invoking the resulting computation or exception continuation let inline CreateTryWithAsync catchFunction computation = - MakeAsync (fun ctxt -> TryWith ctxt computation (fun exn -> Some (catchFunction exn))) + MakeAsync(fun ctxt -> TryWith ctxt computation (fun exn -> Some(catchFunction exn))) /// Call the finallyFunction if the computation results in a cancellation, and then continue with cancellation. /// If the finally function gives an exception then continue with cancellation regardless. @@ -666,22 +721,25 @@ module AsyncPrimitives = /// - Apply `finallyFunction' to argument with exception protection (see CallThenContinue) /// - Hijack check before continuing with cancellation (see CallThenContinue) let CreateWhenCancelledAsync (finallyFunction: OperationCanceledException -> unit) computation = - MakeAsync (fun ctxt -> + MakeAsync(fun ctxt -> let ccont = ctxt.ccont + let ctxt = ctxt.WithCancellationContinuation(fun cexn -> - CallThenContinue finallyFunction cexn (ctxt.WithContinuations(cont = (fun _ -> ccont cexn), econt = (fun _ -> ccont cexn)))) + CallThenContinue + finallyFunction + cexn + (ctxt.WithContinuations(cont = (fun _ -> ccont cexn), econt = (fun _ -> ccont cexn)))) + computation.Invoke ctxt) /// A single pre-allocated computation that fetched the current cancellation token - let cancellationTokenAsync = - MakeAsync (fun ctxt -> ctxt.cont ctxt.aux.token) + let cancellationTokenAsync = MakeAsync(fun ctxt -> ctxt.cont ctxt.aux.token) /// A single pre-allocated computation that returns a unit result /// - Cancellation check (see CreateReturnAsync) /// - Hijack check (see CreateReturnAsync) - let unitAsync = - CreateReturnAsync() + let unitAsync = CreateReturnAsync() /// Implement use/Dispose /// @@ -690,8 +748,10 @@ module AsyncPrimitives = /// - Cancellation check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) /// - Hijack check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) /// - Run 'disposeFunction' with exception protection (see CreateTryFinallyAsync) - let CreateUsingAsync (resource:'T :> IDisposable) (computation:'T -> Async<'a>) : Async<'a> = - let disposeFunction () = Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource + let CreateUsingAsync (resource: 'T :> IDisposable) (computation: 'T -> Async<'a>) : Async<'a> = + let disposeFunction () = + Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource + CreateTryFinallyAsync disposeFunction (CreateCallAsync computation resource) /// - Initial cancellation check (see CreateBindAsync) @@ -714,40 +774,47 @@ module AsyncPrimitives = // // Note: There are allocations during loop set up, but no allocations during iterations of the loop let CreateWhileAsync guardFunc computation = - if guardFunc() then + if guardFunc () then let mutable whileAsync = Unchecked.defaultof<_> - whileAsync <- CreateBindAsync computation (fun () -> if guardFunc() then whileAsync else unitAsync) + + whileAsync <- + CreateBindAsync computation (fun () -> + if guardFunc () then + whileAsync + else + unitAsync) + whileAsync else unitAsync #if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER - /// Implement the while loop construct of async computation expressions - /// - Initial cancellation check before each execution of guard - /// - No initial hijack check before each execution of guard - /// - No cancellation check before each execution of the body after guard - /// - Hijack check before each execution of the body after guard (see Invoke) - /// - Cancellation check after guard fails (see OnSuccess) - /// - Hijack check after guard fails (see OnSuccess) - /// - Apply 'guardFunc' with exception protection (see ProtectCode) - // - // Note: There are allocations during loop set up, but no allocations during iterations of the loop + /// Implement the while loop construct of async computation expressions + /// - Initial cancellation check before each execution of guard + /// - No initial hijack check before each execution of guard + /// - No cancellation check before each execution of the body after guard + /// - Hijack check before each execution of the body after guard (see Invoke) + /// - Cancellation check after guard fails (see OnSuccess) + /// - Hijack check after guard fails (see OnSuccess) + /// - Apply 'guardFunc' with exception protection (see ProtectCode) + // + // Note: There are allocations during loop set up, but no allocations during iterations of the loop // One allocation for While async // One allocation for While async context function - MakeAsync (fun ctxtGuard -> - // One allocation for ctxtLoop reference cell - let mutable ctxtLoop = Unchecked.defaultof<_> - // One allocation for While recursive closure - let rec WhileLoop () = - if ctxtGuard.IsCancellationRequested then - ctxtGuard.OnCancellation () - elif ctxtGuard.ProtectCode guardFunc then - Invoke computation ctxtLoop - else - ctxtGuard.OnSuccess () - // One allocation for While body activation context - ctxtLoop <- ctxtGuard.WithContinuation(WhileLoop) - WhileLoop ()) + MakeAsync(fun ctxtGuard -> + // One allocation for ctxtLoop reference cell + let mutable ctxtLoop = Unchecked.defaultof<_> + // One allocation for While recursive closure + let rec WhileLoop () = + if ctxtGuard.IsCancellationRequested then + ctxtGuard.OnCancellation() + elif ctxtGuard.ProtectCode guardFunc then + Invoke computation ctxtLoop + else + ctxtGuard.OnSuccess() + // One allocation for While body activation context + ctxtLoop <- ctxtGuard.WithContinuation(WhileLoop) + WhileLoop()) #endif /// Implement the for loop construct of async commputation expressions @@ -765,53 +832,53 @@ module AsyncPrimitives = // applying the loop body to the element let CreateForLoopAsync (source: seq<_>) computation = CreateUsingAsync (source.GetEnumerator()) (fun ie -> - CreateWhileAsync - (fun () -> ie.MoveNext()) - (CreateDelayAsync (fun () -> computation ie.Current))) + CreateWhileAsync (fun () -> ie.MoveNext()) (CreateDelayAsync(fun () -> computation ie.Current))) #if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER CreateUsingAsync (source.GetEnumerator()) (fun ie -> // One allocation for While async // One allocation for While async context function - MakeAsync (fun ctxtGuard -> - // One allocation for ctxtLoop reference cell - let mutable ctxtLoop = Unchecked.defaultof<_> - // Two allocations for protected functions - let guardFunc() = ie.MoveNext() - let currentFunc() = ie.Current - // One allocation for ForLoop recursive closure - let rec ForLoop () = - if ctxtGuard.IsCancellationRequested then - ctxtGuard.OnCancellation () - elif ctxtGuard.ProtectCode guardFunc then - let x = ctxtGuard.ProtectCode currentFunc - CallThenInvoke ctxtLoop x computation - else - ctxtGuard.OnSuccess () - // One allocation for loop activation context - ctxtLoop <- ctxtGuard.WithContinuation(ForLoop) - ForLoop ())) + MakeAsync(fun ctxtGuard -> + // One allocation for ctxtLoop reference cell + let mutable ctxtLoop = Unchecked.defaultof<_> + // Two allocations for protected functions + let guardFunc () = + ie.MoveNext() + + let currentFunc () = + ie.Current + // One allocation for ForLoop recursive closure + let rec ForLoop () = + if ctxtGuard.IsCancellationRequested then + ctxtGuard.OnCancellation() + elif ctxtGuard.ProtectCode guardFunc then + let x = ctxtGuard.ProtectCode currentFunc + CallThenInvoke ctxtLoop x computation + else + ctxtGuard.OnSuccess() + // One allocation for loop activation context + ctxtLoop <- ctxtGuard.WithContinuation(ForLoop) + ForLoop())) #endif /// - Initial cancellation check /// - Call syncCtxt.Post with exception protection. THis may fail as it is arbitrary user code let CreateSwitchToAsync (syncCtxt: SynchronizationContext) = - MakeAsyncWithCancelCheck (fun ctxt -> - ctxt.PostWithTrampoline syncCtxt ctxt.cont) + MakeAsyncWithCancelCheck(fun ctxt -> ctxt.PostWithTrampoline syncCtxt ctxt.cont) /// - Initial cancellation check /// - Create Thread and call Start() with exception protection. We don't expect this /// to fail but protect nevertheless. - let CreateSwitchToNewThreadAsync() = - MakeAsyncWithCancelCheck (fun ctxt -> - ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.StartThreadWithTrampoline ctxt.cont)) + let CreateSwitchToNewThreadAsync () = + MakeAsyncWithCancelCheck(fun ctxt -> + ctxt.ProtectCode(fun () -> ctxt.trampolineHolder.StartThreadWithTrampoline ctxt.cont)) /// - Initial cancellation check /// - Call ThreadPool.QueueUserWorkItem with exception protection. We don't expect this /// to fail but protect nevertheless. - let CreateSwitchToThreadPoolAsync() = - MakeAsyncWithCancelCheck (fun ctxt -> - ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.QueueWorkItemWithTrampoline ctxt.cont)) + let CreateSwitchToThreadPoolAsync () = + MakeAsyncWithCancelCheck(fun ctxt -> + ctxt.ProtectCode(fun () -> ctxt.trampolineHolder.QueueWorkItemWithTrampoline ctxt.cont)) /// Post back to the sync context regardless of which continuation is taken /// - Call syncCtxt.Post with exception protection @@ -819,9 +886,11 @@ module AsyncPrimitives = match SynchronizationContext.Current with | null -> ctxt | syncCtxt -> - ctxt.WithContinuations(cont = (fun x -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.cont x)), - econt = (fun edi -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.econt edi)), - ccont = (fun cexn -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont cexn))) + ctxt.WithContinuations( + cont = (fun x -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.cont x)), + econt = (fun edi -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.econt edi)), + ccont = (fun cexn -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont cexn)) + ) [] [] @@ -837,19 +906,22 @@ module AsyncPrimitives = let trampolineHolder = ctxt.trampolineHolder member _.ContinueImmediate res = - let action () = ctxt.cont res - let inline executeImmediately () = trampolineHolder.ExecuteWithTrampoline action + let action () = + ctxt.cont res + + let inline executeImmediately () = + trampolineHolder.ExecuteWithTrampoline action + let currentSyncCtxt = SynchronizationContext.Current + match syncCtxt, currentSyncCtxt with - | null, null -> - executeImmediately () + | null, null -> executeImmediately () // This logic was added in F# 2.0 though is incorrect from the perspective of // how SynchronizationContext is meant to work. However the logic works for // mainline scenarios (WinForms/WPF) and for compatibility reasons we won't change it. | _ when Object.Equals(syncCtxt, currentSyncCtxt) && thread.Equals Thread.CurrentThread -> executeImmediately () - | _ -> - trampolineHolder.PostOrQueueWithTrampoline syncCtxt action + | _ -> trampolineHolder.PostOrQueueWithTrampoline syncCtxt action member _.PostOrQueueWithTrampoline res = trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> ctxt.cont res) @@ -873,25 +945,26 @@ module AsyncPrimitives = let mutable disposed = false // All writers of result are protected by lock on syncRoot. - let syncRoot = obj() + let syncRoot = obj () member x.GetWaitHandle() = lock syncRoot (fun () -> if disposed then raise (System.ObjectDisposedException("ResultCell")) + match resEvent with | null -> // Start in signalled state if a result is already present. let ev = new ManualResetEvent(result.IsSome) resEvent <- ev (ev :> WaitHandle) - | ev -> - (ev :> WaitHandle)) + | ev -> (ev :> WaitHandle)) member x.Close() = lock syncRoot (fun () -> if not disposed then disposed <- true + match resEvent with | null -> () | ev -> @@ -899,7 +972,8 @@ module AsyncPrimitives = resEvent <- null) interface IDisposable with - member x.Dispose() = x.Close() + member x.Dispose() = + x.Close() member x.GrabResult() = match result with @@ -907,47 +981,49 @@ module AsyncPrimitives = | None -> failwith "Unexpected no result" /// Record the result in the ResultCell. - member x.RegisterResult (res:'T, reuseThread) = + member x.RegisterResult(res: 'T, reuseThread) = let grabbedConts = lock syncRoot (fun () -> // Ignore multiple sets of the result. This can happen, e.g. for a race between a cancellation and a success if x.ResultAvailable then [] // invalidOp "multiple results registered for asynchronous operation" else - // In this case the ResultCell has already been disposed, e.g. due to a timeout. - // The result is dropped on the floor. - if disposed then - [] - else - result <- Some res - // If the resEvent exists then set it. If not we can skip setting it altogether and it won't be - // created - match resEvent with - | null -> - () - | ev -> - // Setting the event need to happen under lock so as not to race with Close() - ev.Set () |> ignore - List.rev savedConts) + // In this case the ResultCell has already been disposed, e.g. due to a timeout. + // The result is dropped on the floor. + if disposed then + [] + else + result <- Some res + // If the resEvent exists then set it. If not we can skip setting it altogether and it won't be + // created + match resEvent with + | null -> () + | ev -> + // Setting the event need to happen under lock so as not to race with Close() + ev.Set() |> ignore + + List.rev savedConts) // Run the action outside the lock match grabbedConts with - | [] -> fake() - | [cont] -> + | [] -> fake () + | [ cont ] -> if reuseThread then cont.ContinueImmediate res else cont.PostOrQueueWithTrampoline res | otherwise -> - otherwise |> List.iter (fun cont -> cont.PostOrQueueWithTrampoline res |> unfake) |> fake + otherwise + |> List.iter (fun cont -> cont.PostOrQueueWithTrampoline res |> unfake) + |> fake member x.ResultAvailable = result.IsSome /// Await the result of a result cell, without a direct timeout or direct /// cancellation. That is, the underlying computation must fill the result /// if cancellation or timeout occurs. - member x.AwaitResult_NoDirectCancelOrTimeout = - MakeAsync (fun ctxt -> + member x.AwaitResult_NoDirectCancelOrTimeout = + MakeAsync(fun ctxt -> // Check if a result is available synchronously let resOpt = match result with @@ -955,35 +1031,32 @@ module AsyncPrimitives = | None -> lock syncRoot (fun () -> match result with - | Some _ -> - result + | Some _ -> result | None -> // Otherwise save the continuation and call it in RegisterResult savedConts <- (SuspendedAsync<_>(ctxt)) :: savedConts - None - ) + None) + match resOpt with | Some res -> ctxt.cont res - | None -> fake() - ) + | None -> fake ()) - member x.TryWaitForResultSynchronously (?timeout) : 'T option = + member x.TryWaitForResultSynchronously(?timeout) : 'T option = // Check if a result is available. match result with - | Some _ as r -> - r + | Some _ as r -> r | None -> // Force the creation of the WaitHandle let resHandle = x.GetWaitHandle() // Check again. While we were in GetWaitHandle, a call to RegisterResult may have set result then skipped the // Set because the resHandle wasn't forced. match result with - | Some _ as r -> - r + | Some _ as r -> r | None -> // OK, let's really wait for the Set signal. This may block. let timeout = defaultArg timeout Threading.Timeout.Infinite - let ok = resHandle.WaitOne(millisecondsTimeout= timeout, exitContext=true) + let ok = resHandle.WaitOne(millisecondsTimeout = timeout, exitContext = true) + if ok then // Now the result really must be available result @@ -991,25 +1064,34 @@ module AsyncPrimitives = // timed out None - /// Create an instance of an arbitrary delegate type delegating to the given F# function type FuncDelegate<'T>(f) = - member _.Invoke(sender:obj, a:'T) : unit = ignore sender; f a + member _.Invoke(sender: obj, a: 'T) : unit = + ignore sender + f a + static member Create<'Delegate when 'Delegate :> Delegate>(f) = let obj = FuncDelegate<'T>(f) - let invokeMeth = (typeof>).GetMethod("Invoke", BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) - System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeMeth) :?> 'Delegate + + let invokeMeth = + (typeof>) + .GetMethod("Invoke", BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) + + Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeMeth) :?> 'Delegate [] let QueueAsync cancellationToken cont econt ccont computation = let trampolineHolder = TrampolineHolder() - trampolineHolder.QueueWorkItemWithTrampoline (fun () -> - let ctxt = AsyncActivation.Create cancellationToken trampolineHolder cont econt ccont + + trampolineHolder.QueueWorkItemWithTrampoline(fun () -> + let ctxt = + AsyncActivation.Create cancellationToken trampolineHolder cont econt ccont + computation.Invoke ctxt) /// Run the asynchronous workflow and wait for its result. [] - let QueueAsyncAndWaitForResultSynchronously (token:CancellationToken) computation timeout = + let QueueAsyncAndWaitForResultSynchronously (token: CancellationToken) computation timeout = let token, innerCTS = // If timeout is provided, we govern the async by our own CTS, to cancel // when execution times out. Otherwise, the user-supplied token governs the async. @@ -1020,43 +1102,50 @@ module AsyncPrimitives = subSource.Token, Some subSource use resultCell = new ResultCell>() + QueueAsync token - (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) - (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) - (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) + (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread = true)) + (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread = true)) + (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread = true)) computation |> unfake let res = resultCell.TryWaitForResultSynchronously(?timeout = timeout) + match res with | None -> // timed out // issue cancellation signal - if innerCTS.IsSome then innerCTS.Value.Cancel() + if innerCTS.IsSome then + innerCTS.Value.Cancel() // wait for computation to quiesce; drop result on the floor resultCell.TryWaitForResultSynchronously() |> ignore // dispose the CancellationTokenSource - if innerCTS.IsSome then innerCTS.Value.Dispose() + if innerCTS.IsSome then + innerCTS.Value.Dispose() + raise (System.TimeoutException()) | Some res -> match innerCTS with | Some subSource -> subSource.Dispose() | None -> () + res.Commit() [] - let RunImmediate (cancellationToken:CancellationToken) computation = + let RunImmediate (cancellationToken: CancellationToken) computation = use resultCell = new ResultCell>() let trampolineHolder = TrampolineHolder() - trampolineHolder.ExecuteWithTrampoline (fun () -> + trampolineHolder.ExecuteWithTrampoline(fun () -> let ctxt = AsyncActivation.Create cancellationToken trampolineHolder - (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) - (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) - (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) + (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread = true)) + (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread = true)) + (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread = true)) + computation.Invoke ctxt) |> unfake @@ -1071,25 +1160,28 @@ module AsyncPrimitives = | _ -> QueueAsyncAndWaitForResultSynchronously cancellationToken computation timeout [] - let Start cancellationToken (computation:Async) = + let Start cancellationToken (computation: Async) = QueueAsync cancellationToken - (fun () -> fake()) // nothing to do on success - (fun edi -> edi.ThrowAny()) // raise exception in child - (fun _ -> fake()) // ignore cancellation in child + (fun () -> fake ()) // nothing to do on success + (fun edi -> edi.ThrowAny()) // raise exception in child + (fun _ -> fake ()) // ignore cancellation in child computation |> unfake [] - let StartWithContinuations cancellationToken (computation:Async<'T>) cont econt ccont = + let StartWithContinuations cancellationToken (computation: Async<'T>) cont econt ccont = let trampolineHolder = TrampolineHolder() - trampolineHolder.ExecuteWithTrampoline (fun () -> - let ctxt = AsyncActivation.Create cancellationToken trampolineHolder (cont >> fake) (econt >> fake) (ccont >> fake) + + trampolineHolder.ExecuteWithTrampoline(fun () -> + let ctxt = + AsyncActivation.Create cancellationToken trampolineHolder (cont >> fake) (econt >> fake) (ccont >> fake) + computation.Invoke ctxt) |> unfake [] - let StartAsTask cancellationToken (computation:Async<'T>) taskCreationOptions = + let StartAsTask cancellationToken (computation: Async<'T>) taskCreationOptions = let taskCreationOptions = defaultArg taskCreationOptions TaskCreationOptions.None let tcs = TaskCompletionSource<_>(taskCreationOptions) @@ -1097,6 +1189,7 @@ module AsyncPrimitives = // a) cancellation signal should always propagate to the computation // b) when the task IsCompleted -> nothing is running anymore let task = tcs.Task + QueueAsync cancellationToken (fun r -> tcs.SetResult r |> fake) @@ -1104,12 +1197,14 @@ module AsyncPrimitives = (fun _ -> tcs.SetCanceled() |> fake) computation |> unfake + task // Call the appropriate continuation on completion of a task [] - let OnTaskCompleted (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = + let OnTaskCompleted (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = assert completedTask.IsCompleted + if completedTask.IsCanceled then let edi = ExceptionDispatchInfo.Capture(TaskCanceledException completedTask) ctxt.econt edi @@ -1124,8 +1219,9 @@ module AsyncPrimitives = // the overall async (they may be governed by different cancellation tokens, or // the task may not have a cancellation token at all). [] - let OnUnitTaskCompleted (completedTask: Task) (ctxt: AsyncActivation) = + let OnUnitTaskCompleted (completedTask: Task) (ctxt: AsyncActivation) = assert completedTask.IsCompleted + if completedTask.IsCanceled then let edi = ExceptionDispatchInfo.Capture(TaskCanceledException(completedTask)) ctxt.econt edi @@ -1140,11 +1236,13 @@ module AsyncPrimitives = // completing the task. This will install a new trampoline on that thread and continue the // execution of the async there. [] - let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = - task.ContinueWith(Action>(fun completedTask -> - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> - OnTaskCompleted completedTask ctxt) - |> unfake), TaskContinuationOptions.ExecuteSynchronously) + let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = + task.ContinueWith( + Action>(fun completedTask -> + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> OnTaskCompleted completedTask ctxt) + |> unfake), + TaskContinuationOptions.ExecuteSynchronously + ) |> ignore |> fake @@ -1154,11 +1252,13 @@ module AsyncPrimitives = // execution of the async there. [] let AttachContinuationToUnitTask (task: Task) (ctxt: AsyncActivation) = - task.ContinueWith(Action(fun completedTask -> - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> - OnUnitTaskCompleted completedTask ctxt) - |> unfake), TaskContinuationOptions.ExecuteSynchronously) - |> ignore + task.ContinueWith( + Action(fun completedTask -> + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> OnUnitTaskCompleted completedTask ctxt) + |> unfake), + TaskContinuationOptions.ExecuteSynchronously + ) + |> ignore |> fake /// Removes a registration places on a cancellation token @@ -1173,7 +1273,7 @@ module AsyncPrimitives = let DisposeTimer (timer: byref) = match timer with | None -> () - | Some t -> + | Some t -> timer <- None t.Dispose() @@ -1188,119 +1288,137 @@ module AsyncPrimitives = /// Unregisters a delegate handler, helper for AwaitEvent let RemoveHandler (event: IEvent<_, _>) (del: byref<'Delegate option>) = match del with - | Some d -> + | Some d -> del <- None event.RemoveHandler d | None -> () [] - type AsyncIAsyncResult<'T>(callback: System.AsyncCallback, state:obj) = - // This gets set to false if the result is not available by the - // time the IAsyncResult is returned to the caller of Begin - let mutable completedSynchronously = true + type AsyncIAsyncResult<'T>(callback: System.AsyncCallback, state: obj) = + // This gets set to false if the result is not available by the + // time the IAsyncResult is returned to the caller of Begin + let mutable completedSynchronously = true + + let mutable disposed = false - let mutable disposed = false + let cts = new CancellationTokenSource() - let cts = new CancellationTokenSource() + let result = new ResultCell>() - let result = new ResultCell>() + member s.SetResult(v: AsyncResult<'T>) = + result.RegisterResult(v, reuseThread = true) |> unfake - member s.SetResult(v: AsyncResult<'T>) = - result.RegisterResult(v, reuseThread=true) |> unfake - match callback with - | null -> () - | d -> - // The IASyncResult becomes observable here - d.Invoke (s :> System.IAsyncResult) + match callback with + | null -> () + | d -> + // The IASyncResult becomes observable here + d.Invoke(s :> System.IAsyncResult) - member s.GetResult() = - match result.TryWaitForResultSynchronously (-1) with - | Some (AsyncResult.Ok v) -> v - | Some (AsyncResult.Error edi) -> edi.ThrowAny() - | Some (AsyncResult.Canceled err) -> raise err - | None -> failwith "unreachable" + member s.GetResult() = + match result.TryWaitForResultSynchronously(-1) with + | Some (AsyncResult.Ok v) -> v + | Some (AsyncResult.Error edi) -> edi.ThrowAny() + | Some (AsyncResult.Canceled err) -> raise err + | None -> failwith "unreachable" - member x.IsClosed = disposed + member x.IsClosed = disposed - member x.Close() = - if not disposed then - disposed <- true - cts.Dispose() - result.Close() + member x.Close() = + if not disposed then + disposed <- true + cts.Dispose() + result.Close() - member x.Token = cts.Token + member x.Token = cts.Token - member x.CancelAsync() = cts.Cancel() + member x.CancelAsync() = + cts.Cancel() - member x.CheckForNotSynchronous() = - if not result.ResultAvailable then - completedSynchronously <- false + member x.CheckForNotSynchronous() = + if not result.ResultAvailable then + completedSynchronously <- false - interface System.IAsyncResult with - member _.IsCompleted = result.ResultAvailable - member _.CompletedSynchronously = completedSynchronously - member _.AsyncWaitHandle = result.GetWaitHandle() - member _.AsyncState = state + interface System.IAsyncResult with + member _.IsCompleted = result.ResultAvailable + member _.CompletedSynchronously = completedSynchronously + member _.AsyncWaitHandle = result.GetWaitHandle() + member _.AsyncState = state - interface System.IDisposable with - member x.Dispose() = x.Close() + interface System.IDisposable with + member x.Dispose() = + x.Close() module AsBeginEndHelpers = let beginAction (computation, callback, state) = let aiar = new AsyncIAsyncResult<'T>(callback, state) - let cont res = aiar.SetResult (AsyncResult.Ok res) - let econt edi = aiar.SetResult (AsyncResult.Error edi) - let ccont cexn = aiar.SetResult (AsyncResult.Canceled cexn) + + let cont res = + aiar.SetResult(AsyncResult.Ok res) + + let econt edi = + aiar.SetResult(AsyncResult.Error edi) + + let ccont cexn = + aiar.SetResult(AsyncResult.Canceled cexn) + StartWithContinuations aiar.Token computation cont econt ccont aiar.CheckForNotSynchronous() (aiar :> IAsyncResult) - let endAction<'T> (iar:IAsyncResult) = + let endAction<'T> (iar: IAsyncResult) = match iar with | :? AsyncIAsyncResult<'T> as aiar -> if aiar.IsClosed then raise (System.ObjectDisposedException("AsyncResult")) else let res = aiar.GetResult() - aiar.Close () + aiar.Close() res - | _ -> - invalidArg "iar" (SR.GetString(SR.mismatchIAREnd)) + | _ -> invalidArg "iar" (SR.GetString(SR.mismatchIAREnd)) - let cancelAction<'T>(iar:IAsyncResult) = + let cancelAction<'T> (iar: IAsyncResult) = match iar with - | :? AsyncIAsyncResult<'T> as aiar -> - aiar.CancelAsync() - | _ -> - invalidArg "iar" (SR.GetString(SR.mismatchIARCancel)) + | :? AsyncIAsyncResult<'T> as aiar -> aiar.CancelAsync() + | _ -> invalidArg "iar" (SR.GetString(SR.mismatchIARCancel)) open AsyncPrimitives [] type AsyncBuilder() = - member _.Zero () = unitAsync + member _.Zero() = + unitAsync - member _.Delay generator = CreateDelayAsync generator + member _.Delay generator = + CreateDelayAsync generator - member inline _.Return value = CreateReturnAsync value + member inline _.Return value = + CreateReturnAsync value - member inline _.ReturnFrom (computation:Async<_>) = computation + member inline _.ReturnFrom(computation: Async<_>) = + computation - member inline _.Bind (computation, binder) = CreateBindAsync computation binder + member inline _.Bind(computation, binder) = + CreateBindAsync computation binder - member _.Using (resource, binder) = CreateUsingAsync resource binder + member _.Using(resource, binder) = + CreateUsingAsync resource binder - member _.While (guard, computation) = CreateWhileAsync guard computation + member _.While(guard, computation) = + CreateWhileAsync guard computation - member _.For (sequence, body) = CreateForLoopAsync sequence body + member _.For(sequence, body) = + CreateForLoopAsync sequence body - member inline _.Combine (computation1, computation2) = CreateSequentialAsync computation1 computation2 + member inline _.Combine(computation1, computation2) = + CreateSequentialAsync computation1 computation2 - member inline _.TryFinally (computation, compensation) = CreateTryFinallyAsync compensation computation + member inline _.TryFinally(computation, compensation) = + CreateTryFinallyAsync compensation computation - member inline _.TryWith (computation, catchHandler) = CreateTryWithAsync catchHandler computation + member inline _.TryWith(computation, catchHandler) = + CreateTryWithAsync catchHandler computation - // member inline _.TryWithFilter (computation, catchHandler) = CreateTryWithFilterAsync catchHandler computation +// member inline _.TryWithFilter (computation, catchHandler) = CreateTryWithFilterAsync catchHandler computation [] module AsyncBuilderImpl = @@ -1311,35 +1429,50 @@ type Async = static member CancellationToken = cancellationTokenAsync - static member CancelCheck () = unitAsync + static member CancelCheck() = + unitAsync - static member FromContinuations (callback: ('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) : Async<'T> = - MakeAsyncWithCancelCheck (fun ctxt -> + static member FromContinuations + (callback: ('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) + : Async<'T> = + MakeAsyncWithCancelCheck(fun ctxt -> let mutable underCurrentThreadStack = true let mutable contToTailCall = None let thread = Thread.CurrentThread let latch = Latch() + let once cont x = - if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + if not (latch.Enter()) then + invalidOp (SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + if Thread.CurrentThread.Equals thread && underCurrentThreadStack then contToTailCall <- Some(fun () -> cont x) elif Trampoline.ThisThreadHasTrampoline then let syncCtxt = SynchronizationContext.Current - ctxt.trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> cont x) |> unfake + + ctxt.trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> cont x) + |> unfake else - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> cont x ) |> unfake + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> cont x) |> unfake + try - callback (once ctxt.cont, (fun exn -> once ctxt.econt (ExceptionDispatchInfo.RestoreOrCapture exn)), once ctxt.ccont) + callback ( + once ctxt.cont, + (fun exn -> once ctxt.econt (ExceptionDispatchInfo.RestoreOrCapture exn)), + once ctxt.ccont + ) with exn -> - if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + if not (latch.Enter()) then + invalidOp (SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + let edi = ExceptionDispatchInfo.RestoreOrCapture exn ctxt.econt edi |> unfake underCurrentThreadStack <- false match contToTailCall with - | Some k -> k() - | _ -> fake()) + | Some k -> k () + | _ -> fake ()) static member DefaultCancellationToken = defaultCancellationTokenSource.Token @@ -1348,110 +1481,130 @@ type Async = // set new CancellationTokenSource before calling Cancel - otherwise if Cancel throws token will stay unchanged defaultCancellationTokenSource <- new CancellationTokenSource() cts.Cancel() - // we do not dispose the old default CTS - let GC collect it + // we do not dispose the old default CTS - let GC collect it - static member Catch (computation: Async<'T>) = - MakeAsync (fun ctxt -> + static member Catch(computation: Async<'T>) = + MakeAsync(fun ctxt -> // Turn the success or exception into data - let newCtxt = ctxt.WithContinuations(cont = (fun res -> ctxt.cont (Choice1Of2 res)), - econt = (fun edi -> ctxt.cont (Choice2Of2 (edi.GetAssociatedSourceException())))) + let newCtxt = + ctxt.WithContinuations( + cont = (fun res -> ctxt.cont (Choice1Of2 res)), + econt = (fun edi -> ctxt.cont (Choice2Of2(edi.GetAssociatedSourceException()))) + ) + computation.Invoke newCtxt) - static member RunSynchronously (computation: Async<'T>, ?timeout, ?cancellationToken:CancellationToken) = + static member RunSynchronously(computation: Async<'T>, ?timeout, ?cancellationToken: CancellationToken) = let timeout, cancellationToken = match cancellationToken with | None -> timeout, defaultCancellationTokenSource.Token | Some token when not token.CanBeCanceled -> timeout, token | Some token -> None, token + AsyncPrimitives.RunSynchronously cancellationToken computation timeout - static member Start (computation, ?cancellationToken) = - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + static member Start(computation, ?cancellationToken) = + let cancellationToken = + defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.Start cancellationToken computation - static member StartAsTask (computation, ?taskCreationOptions, ?cancellationToken)= - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + static member StartAsTask(computation, ?taskCreationOptions, ?cancellationToken) = + let cancellationToken = + defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions - static member StartChildAsTask (computation, ?taskCreationOptions) = - async { + static member StartChildAsTask(computation, ?taskCreationOptions) = + async { let! cancellationToken = cancellationTokenAsync return AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions } - static member Parallel (computations: seq>) = - Async.Parallel(computations, ?maxDegreeOfParallelism=None) + static member Parallel(computations: seq>) = + Async.Parallel(computations, ?maxDegreeOfParallelism = None) - static member Parallel (computations: seq>, ?maxDegreeOfParallelism: int) = + static member Parallel(computations: seq>, ?maxDegreeOfParallelism: int) = match maxDegreeOfParallelism with - | Some x when x < 1 -> raise(System.ArgumentException(String.Format(SR.GetString(SR.maxDegreeOfParallelismNotPositive), x), "maxDegreeOfParallelism")) + | Some x when x < 1 -> + raise ( + System.ArgumentException( + String.Format(SR.GetString(SR.maxDegreeOfParallelismNotPositive), x), + "maxDegreeOfParallelism" + ) + ) | _ -> () - MakeAsyncWithCancelCheck (fun ctxt -> + MakeAsyncWithCancelCheck(fun ctxt -> // manually protect eval of seq let result = try - Choice1Of2 (Seq.toArray computations) + Choice1Of2(Seq.toArray computations) with exn -> - Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) + Choice2Of2(ExceptionDispatchInfo.RestoreOrCapture exn) match result with | Choice2Of2 edi -> ctxt.econt edi - | Choice1Of2 [| |] -> ctxt.cont [| |] + | Choice1Of2 [||] -> ctxt.cont [||] | Choice1Of2 computations -> - ctxt.ProtectCode (fun () -> - let ctxt = DelimitSyncContext ctxt // manually resync - let mutable count = computations.Length - let mutable firstExn = None - let results = Array.zeroCreate computations.Length - // Attempt to cancel the individual operations if an exception happens on any of the other threads - let innerCTS = new LinkedSubSource(ctxt.token) - - let finishTask remaining = - if (remaining = 0) then - innerCTS.Dispose() - match firstExn with - | None -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont results) - | Some (Choice1Of2 exn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) - | Some (Choice2Of2 cexn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) - else - fake() + ctxt.ProtectCode(fun () -> + let ctxt = DelimitSyncContext ctxt // manually resync + let mutable count = computations.Length + let mutable firstExn = None + let results = Array.zeroCreate computations.Length + // Attempt to cancel the individual operations if an exception happens on any of the other threads + let innerCTS = new LinkedSubSource(ctxt.token) + + let finishTask remaining = + if (remaining = 0) then + innerCTS.Dispose() + + match firstExn with + | None -> ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.cont results) + | Some (Choice1Of2 exn) -> + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.econt exn) + | Some (Choice2Of2 cexn) -> + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.ccont cexn) + else + fake () + + // recordSuccess and recordFailure between them decrement count to 0 and + // as soon as 0 is reached dispose innerCancellationSource + + let recordSuccess i res = + results.[i] <- res + finishTask (Interlocked.Decrement &count) + + let recordFailure exn = + // capture first exception and then decrement the counter to avoid race when + // - thread 1 decremented counter and preempted by the scheduler + // - thread 2 decremented counter and called finishTask + // since exception is not yet captured - finishtask will fall into success branch + match Interlocked.CompareExchange(&firstExn, Some exn, None) with + | None -> + // signal cancellation before decrementing the counter - this guarantees that no other thread can sneak to finishTask and dispose innerCTS + // NOTE: Cancel may introduce reentrancy - i.e. when handler registered for the cancellation token invokes cancel continuation that will call 'recordFailure' + // to correctly handle this we need to return decremented value, not the current value of 'count' otherwise we may invoke finishTask with value '0' several times + innerCTS.Cancel() + | _ -> () - // recordSuccess and recordFailure between them decrement count to 0 and - // as soon as 0 is reached dispose innerCancellationSource + finishTask (Interlocked.Decrement &count) - let recordSuccess i res = - results.[i] <- res - finishTask(Interlocked.Decrement &count) + // If maxDegreeOfParallelism is set but is higher then the number of tasks we have we set it back to None to fall into the simple + // queue all items branch + let maxDegreeOfParallelism = + match maxDegreeOfParallelism with + | None -> None + | Some x when x >= computations.Length -> None + | Some _ as x -> x - let recordFailure exn = - // capture first exception and then decrement the counter to avoid race when - // - thread 1 decremented counter and preempted by the scheduler - // - thread 2 decremented counter and called finishTask - // since exception is not yet captured - finishtask will fall into success branch - match Interlocked.CompareExchange(&firstExn, Some exn, None) with - | None -> - // signal cancellation before decrementing the counter - this guarantees that no other thread can sneak to finishTask and dispose innerCTS - // NOTE: Cancel may introduce reentrancy - i.e. when handler registered for the cancellation token invokes cancel continuation that will call 'recordFailure' - // to correctly handle this we need to return decremented value, not the current value of 'count' otherwise we may invoke finishTask with value '0' several times - innerCTS.Cancel() - | _ -> () - finishTask(Interlocked.Decrement &count) - - // If maxDegreeOfParallelism is set but is higher then the number of tasks we have we set it back to None to fall into the simple - // queue all items branch - let maxDegreeOfParallelism = + // Simple case (no maxDegreeOfParallelism) just queue all the work, if we have maxDegreeOfParallelism set we start that many workers + // which will make progress on the actual computations match maxDegreeOfParallelism with - | None -> None - | Some x when x >= computations.Length -> None - | Some _ as x -> x - - // Simple case (no maxDegreeOfParallelism) just queue all the work, if we have maxDegreeOfParallelism set we start that many workers - // which will make progress on the actual computations - match maxDegreeOfParallelism with - | None -> - computations |> Array.iteri (fun i p -> - QueueAsync + | None -> + computations + |> Array.iteri (fun i p -> + QueueAsync innerCTS.Token // on success, record the result (fun res -> recordSuccess i res) @@ -1461,52 +1614,62 @@ type Async = (fun cexn -> recordFailure (Choice2Of2 cexn)) p |> unfake) - | Some maxDegreeOfParallelism -> - let mutable i = -1 - let rec worker (trampolineHolder : TrampolineHolder) = - if i < computations.Length then - let j = Interlocked.Increment &i - if j < computations.Length then - if innerCTS.Token.IsCancellationRequested then - let cexn = OperationCanceledException (innerCTS.Token) - recordFailure (Choice2Of2 cexn) |> unfake - worker trampolineHolder - else - let taskCtxt = - AsyncActivation.Create - innerCTS.Token - trampolineHolder - (fun res -> recordSuccess j res |> unfake; worker trampolineHolder |> fake) - (fun edi -> recordFailure (Choice1Of2 edi) |> unfake; worker trampolineHolder |> fake) - (fun cexn -> recordFailure (Choice2Of2 cexn) |> unfake; worker trampolineHolder |> fake) - computations.[j].Invoke taskCtxt |> unfake - - for x = 1 to maxDegreeOfParallelism do - let trampolineHolder = TrampolineHolder() - trampolineHolder.QueueWorkItemWithTrampoline (fun () -> - worker trampolineHolder |> fake) - |> unfake - - fake())) - - static member Sequential (computations: seq>) = - Async.Parallel(computations, maxDegreeOfParallelism=1) + | Some maxDegreeOfParallelism -> + let mutable i = -1 + + let rec worker (trampolineHolder: TrampolineHolder) = + if i < computations.Length then + let j = Interlocked.Increment &i + + if j < computations.Length then + if innerCTS.Token.IsCancellationRequested then + let cexn = OperationCanceledException(innerCTS.Token) + recordFailure (Choice2Of2 cexn) |> unfake + worker trampolineHolder + else + let taskCtxt = + AsyncActivation.Create + innerCTS.Token + trampolineHolder + (fun res -> + recordSuccess j res |> unfake + worker trampolineHolder |> fake) + (fun edi -> + recordFailure (Choice1Of2 edi) |> unfake + worker trampolineHolder |> fake) + (fun cexn -> + recordFailure (Choice2Of2 cexn) |> unfake + worker trampolineHolder |> fake) + + computations.[j].Invoke taskCtxt |> unfake + + for x = 1 to maxDegreeOfParallelism do + let trampolineHolder = TrampolineHolder() + + trampolineHolder.QueueWorkItemWithTrampoline(fun () -> worker trampolineHolder |> fake) + |> unfake + + fake ())) + + static member Sequential(computations: seq>) = + Async.Parallel(computations, maxDegreeOfParallelism = 1) static member Choice(computations: Async<'T option> seq) : Async<'T option> = - MakeAsyncWithCancelCheck (fun ctxt -> + MakeAsyncWithCancelCheck(fun ctxt -> // manually protect eval of seq let result = try - Choice1Of2 (Seq.toArray computations) + Choice1Of2(Seq.toArray computations) with exn -> - Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) + Choice2Of2(ExceptionDispatchInfo.RestoreOrCapture exn) match result with | Choice2Of2 edi -> ctxt.econt edi - | Choice1Of2 [| |] -> ctxt.cont None + | Choice1Of2 [||] -> ctxt.cont None | Choice1Of2 computations -> - let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode (fun () -> + let ctxt = DelimitSyncContext ctxt + + ctxt.ProtectCode(fun () -> let mutable count = computations.Length let mutable noneCount = 0 let mutable someOrExnCount = 0 @@ -1517,15 +1680,17 @@ type Async = match result with | Some _ -> if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont result) + innerCts.Cancel() + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.cont result) else - fake() + fake () | None -> if Interlocked.Increment &noneCount = computations.Length then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont None) + innerCts.Cancel() + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.cont None) else - fake() + fake () if Interlocked.Decrement &count = 0 then innerCts.Dispose() @@ -1535,9 +1700,10 @@ type Async = let econt (exn: ExceptionDispatchInfo) = let result = if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) + innerCts.Cancel() + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.econt exn) else - fake() + fake () if Interlocked.Decrement &count = 0 then innerCts.Dispose() @@ -1547,9 +1713,10 @@ type Async = let ccont (cexn: OperationCanceledException) = let result = if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) + innerCts.Cancel() + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.ccont cexn) else - fake() + fake () if Interlocked.Decrement &count = 0 then innerCts.Dispose() @@ -1559,85 +1726,131 @@ type Async = for computation in computations do QueueAsync innerCts.Token scont econt ccont computation |> unfake - fake())) + fake ())) /// StartWithContinuations, except the exception continuation is given an ExceptionDispatchInfo - static member StartWithContinuationsUsingDispatchInfo(computation:Async<'T>, continuation, exceptionContinuation, cancellationContinuation, ?cancellationToken) : unit = - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token - AsyncPrimitives.StartWithContinuations cancellationToken computation continuation exceptionContinuation cancellationContinuation + static member StartWithContinuationsUsingDispatchInfo + ( + computation: Async<'T>, + continuation, + exceptionContinuation, + cancellationContinuation, + ?cancellationToken + ) : unit = + let cancellationToken = + defaultArg cancellationToken defaultCancellationTokenSource.Token + + AsyncPrimitives.StartWithContinuations + cancellationToken + computation + continuation + exceptionContinuation + cancellationContinuation + + static member StartWithContinuations + ( + computation: Async<'T>, + continuation, + exceptionContinuation, + cancellationContinuation, + ?cancellationToken + ) : unit = + Async.StartWithContinuationsUsingDispatchInfo( + computation, + continuation, + (fun edi -> exceptionContinuation (edi.GetAssociatedSourceException())), + cancellationContinuation, + ?cancellationToken = cancellationToken + ) - static member StartWithContinuations(computation:Async<'T>, continuation, exceptionContinuation, cancellationContinuation, ?cancellationToken) : unit = - Async.StartWithContinuationsUsingDispatchInfo(computation, continuation, (fun edi -> exceptionContinuation (edi.GetAssociatedSourceException())), cancellationContinuation, ?cancellationToken=cancellationToken) + static member StartImmediateAsTask(computation: Async<'T>, ?cancellationToken) : Task<'T> = + let cancellationToken = + defaultArg cancellationToken defaultCancellationTokenSource.Token - static member StartImmediateAsTask (computation: Async<'T>, ?cancellationToken ) : Task<'T>= - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token let ts = TaskCompletionSource<'T>() let task = ts.Task + Async.StartWithContinuations( computation, (fun k -> ts.SetResult k), (fun exn -> ts.SetException exn), (fun _ -> ts.SetCanceled()), - cancellationToken) + cancellationToken + ) + task - static member StartImmediate(computation:Async, ?cancellationToken) : unit = - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + static member StartImmediate(computation: Async, ?cancellationToken) : unit = + let cancellationToken = + defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.StartWithContinuations cancellationToken computation id (fun edi -> edi.ThrowAny()) ignore - static member Sleep (millisecondsDueTime: int64) : Async = - MakeAsyncWithCancelCheck (fun ctxt -> + static member Sleep(millisecondsDueTime: int64) : Async = + MakeAsyncWithCancelCheck(fun ctxt -> let ctxt = DelimitSyncContext ctxt let mutable edi = null let latch = Latch() let mutable timer: Timer option = None let mutable registration: CancellationTokenRegistration option = None + registration <- - ctxt.token.Register(Action(fun () -> - if latch.Enter() then - // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration - DisposeTimer &timer - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake) - ) |> Some + ctxt.token.Register( + Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration + DisposeTimer &timer + + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> + ctxt.ccont (OperationCanceledException(ctxt.token))) + |> unfake) + ) + |> Some + try - timer <- new Timer(TimerCallback(fun _ -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration - DisposeTimer &timer - // Now we're done, so call the continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont()) |> unfake), - null, dueTime=millisecondsDueTime, period = -1L) |> Some + timer <- + new Timer( + TimerCallback(fun _ -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration + DisposeTimer &timer + // Now we're done, so call the continuation + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.cont ()) |> unfake), + null, + dueTime = millisecondsDueTime, + period = -1L + ) + |> Some with exn -> if latch.Enter() then // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + DisposeCancellationRegistration ®istration // Prepare to call exception continuation edi <- ExceptionDispatchInfo.RestoreOrCapture exn // Call exception continuation if necessary match edi with - | null -> - fake() - | _ -> - ctxt.econt edi) + | null -> fake () + | _ -> ctxt.econt edi) - static member Sleep (millisecondsDueTime: int32) : Async = - Async.Sleep (millisecondsDueTime |> int64) + static member Sleep(millisecondsDueTime: int32) : Async = + Async.Sleep(millisecondsDueTime |> int64) - static member Sleep (dueTime: TimeSpan) = + static member Sleep(dueTime: TimeSpan) = if dueTime < TimeSpan.Zero then raise (ArgumentOutOfRangeException("dueTime")) else - Async.Sleep (dueTime.TotalMilliseconds |> Checked.int64) + Async.Sleep(dueTime.TotalMilliseconds |> Checked.int64) /// Wait for a wait handle. Both timeout and cancellation are supported - static member AwaitWaitHandle(waitHandle: WaitHandle, ?millisecondsTimeout:int) = - MakeAsyncWithCancelCheck (fun ctxt -> + static member AwaitWaitHandle(waitHandle: WaitHandle, ?millisecondsTimeout: int) = + MakeAsyncWithCancelCheck(fun ctxt -> let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite + if millisecondsTimeout = 0 then - let ok = waitHandle.WaitOne(0, exitContext=false) + let ok = waitHandle.WaitOne(0, exitContext = false) ctxt.cont ok else let ctxt = DelimitSyncContext ctxt @@ -1645,42 +1858,51 @@ type Async = let latch = Latch() let mutable rwh: RegisteredWaitHandle option = None let mutable registration: CancellationTokenRegistration option = None + registration <- - ctxt.token.Register(Action(fun () -> - if latch.Enter() then - // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration + ctxt.token.Register( + Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration - UnregisterWaitHandle &rwh + UnregisterWaitHandle &rwh - // Call the cancellation continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake)) + // Call the cancellation continuation + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> + ctxt.ccont (OperationCanceledException(ctxt.token))) + |> unfake) + ) |> Some try - rwh <- ThreadPool.RegisterWaitForSingleObject(waitObject=waitHandle, - callBack=WaitOrTimerCallback(fun _ timeOut -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration - UnregisterWaitHandle &rwh - // Call the success continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont (not timeOut)) |> unfake), - state=null, - millisecondsTimeOutInterval=millisecondsTimeout, - executeOnlyOnce=true) - |> Some + rwh <- + ThreadPool.RegisterWaitForSingleObject( + waitObject = waitHandle, + callBack = + WaitOrTimerCallback(fun _ timeOut -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration + UnregisterWaitHandle &rwh + // Call the success continuation + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> ctxt.cont (not timeOut)) + |> unfake), + state = null, + millisecondsTimeOutInterval = millisecondsTimeout, + executeOnlyOnce = true + ) + |> Some with exn -> if latch.Enter() then // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + DisposeCancellationRegistration ®istration // Prepare to call exception continuation edi <- ExceptionDispatchInfo.RestoreOrCapture exn // Call exception continuation if necessary match edi with - | null -> - fake() + | null -> fake () | _ -> // Call the exception continuation ctxt.econt edi) @@ -1690,7 +1912,7 @@ type Async = if iar.CompletedSynchronously then return true else - return! Async.AwaitWaitHandle(iar.AsyncWaitHandle, ?millisecondsTimeout=millisecondsTimeout) + return! Async.AwaitWaitHandle(iar.AsyncWaitHandle, ?millisecondsTimeout = millisecondsTimeout) } /// Await and use the result of a result cell. The resulting async doesn't support cancellation @@ -1705,25 +1927,37 @@ type Async = /// Await the result of a result cell belonging to a child computation. The resulting async supports timeout and if /// it happens the child computation will be cancelled. The resulting async doesn't support cancellation /// directly, rather the underlying computation must fill the result if cancellation occurs. - static member AwaitAndBindChildResult(innerCTS: CancellationTokenSource, resultCell: ResultCell>, millisecondsTimeout) : Async<'T> = + static member AwaitAndBindChildResult + ( + innerCTS: CancellationTokenSource, + resultCell: ResultCell>, + millisecondsTimeout + ) : Async<'T> = match millisecondsTimeout with - | None | Some -1 -> - resultCell |> Async.AwaitAndBindResult_NoDirectCancelOrTimeout + | None + | Some -1 -> resultCell |> Async.AwaitAndBindResult_NoDirectCancelOrTimeout | Some 0 -> - async { if resultCell.ResultAvailable then - let res = resultCell.GrabResult() - return res.Commit() - else - return raise (System.TimeoutException()) } + async { + if resultCell.ResultAvailable then + let res = resultCell.GrabResult() + return res.Commit() + else + return raise (System.TimeoutException()) + } | _ -> - async { + async { try if resultCell.ResultAvailable then let res = resultCell.GrabResult() return res.Commit() else - let! ok = Async.AwaitWaitHandle (resultCell.GetWaitHandle(), ?millisecondsTimeout=millisecondsTimeout) + let! ok = + Async.AwaitWaitHandle( + resultCell.GetWaitHandle(), + ?millisecondsTimeout = millisecondsTimeout + ) + if ok then let res = resultCell.GrabResult() return res.Commit() @@ -1731,36 +1965,41 @@ type Async = // issue cancellation signal innerCTS.Cancel() // wait for computation to quiesce - let! _ = Async.AwaitWaitHandle (resultCell.GetWaitHandle()) + let! _ = Async.AwaitWaitHandle(resultCell.GetWaitHandle()) return raise (System.TimeoutException()) finally - resultCell.Close() + resultCell.Close() } - - static member FromBeginEnd(beginAction, endAction, ?cancelAction): Async<'T> = + static member FromBeginEnd(beginAction, endAction, ?cancelAction) : Async<'T> = async { let! ct = cancellationTokenAsync let resultCell = new ResultCell<_>() let latch = Latch() let mutable registration: CancellationTokenRegistration option = None + registration <- - ct.Register(Action(fun () -> - if latch.Enter() then - // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration - - // Call the cancellation function. Ignore any exceptions from the - // cancellation function. - match cancelAction with - | None -> () - | Some cancel -> - try cancel() with _ -> () - - // Register the cancellation result. - let canceledResult = Canceled (OperationCanceledException ct) - resultCell.RegisterResult(canceledResult, reuseThread=true) |> unfake)) + ct.Register( + Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration + + // Call the cancellation function. Ignore any exceptions from the + // cancellation function. + match cancelAction with + | None -> () + | Some cancel -> + try + cancel () + with _ -> + () + + // Register the cancellation result. + let canceledResult = Canceled(OperationCanceledException ct) + resultCell.RegisterResult(canceledResult, reuseThread = true) |> unfake) + ) |> Some let callback = @@ -1768,7 +2007,7 @@ type Async = if not iar.CompletedSynchronously then if latch.Enter() then // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + DisposeCancellationRegistration ®istration // Run the endAction and collect its result. let res = @@ -1778,13 +2017,14 @@ type Async = let edi = ExceptionDispatchInfo.RestoreOrCapture exn Error edi - // Register the result. - resultCell.RegisterResult(res, reuseThread=true) |> unfake) + // Register the result. + resultCell.RegisterResult(res, reuseThread = true) |> unfake) + + let (iar: IAsyncResult) = beginAction (callback, (null: obj)) - let (iar:IAsyncResult) = beginAction (callback, (null:obj)) if iar.CompletedSynchronously then // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + DisposeCancellationRegistration ®istration return endAction iar else // Note: ok to use "NoDirectCancel" here because cancellation has been registered above @@ -1792,27 +2032,33 @@ type Async = return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } - - static member FromBeginEnd(arg, beginAction, endAction, ?cancelAction): Async<'T> = - Async.FromBeginEnd((fun (iar, state) -> beginAction(arg, iar, state)), endAction, ?cancelAction=cancelAction) - - static member FromBeginEnd(arg1, arg2, beginAction, endAction, ?cancelAction): Async<'T> = - Async.FromBeginEnd((fun (iar, state) -> beginAction(arg1, arg2, iar, state)), endAction, ?cancelAction=cancelAction) - - static member FromBeginEnd(arg1, arg2, arg3, beginAction, endAction, ?cancelAction): Async<'T> = - Async.FromBeginEnd((fun (iar, state) -> beginAction(arg1, arg2, arg3, iar, state)), endAction, ?cancelAction=cancelAction) - - static member AsBeginEnd<'Arg, 'T> (computation:('Arg -> Async<'T>)) : - // The 'Begin' member - ('Arg * System.AsyncCallback * obj -> System.IAsyncResult) * - // The 'End' member - (System.IAsyncResult -> 'T) * - // The 'Cancel' member - (System.IAsyncResult -> unit) = - let beginAction = fun (a1, callback, state) -> AsBeginEndHelpers.beginAction ((computation a1), callback, state) - beginAction, AsBeginEndHelpers.endAction<'T>, AsBeginEndHelpers.cancelAction<'T> - - static member AwaitEvent(event:IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = + static member FromBeginEnd(arg, beginAction, endAction, ?cancelAction) : Async<'T> = + Async.FromBeginEnd((fun (iar, state) -> beginAction (arg, iar, state)), endAction, ?cancelAction = cancelAction) + + static member FromBeginEnd(arg1, arg2, beginAction, endAction, ?cancelAction) : Async<'T> = + Async.FromBeginEnd( + (fun (iar, state) -> beginAction (arg1, arg2, iar, state)), + endAction, + ?cancelAction = cancelAction + ) + + static member FromBeginEnd(arg1, arg2, arg3, beginAction, endAction, ?cancelAction) : Async<'T> = + Async.FromBeginEnd( + (fun (iar, state) -> beginAction (arg1, arg2, arg3, iar, state)), + endAction, + ?cancelAction = cancelAction + ) + + static member AsBeginEnd<'Arg, 'T> + (computation: ('Arg -> Async<'T>)) + // The 'Begin' member + : ('Arg * System.AsyncCallback * obj -> System.IAsyncResult) * (System.IAsyncResult -> 'T) * (System.IAsyncResult -> unit) = + let beginAction = + fun (a1, callback, state) -> AsBeginEndHelpers.beginAction ((computation a1), callback, state) + + beginAction, AsBeginEndHelpers.endAction<'T>, AsBeginEndHelpers.cancelAction<'T> + + static member AwaitEvent(event: IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = async { let! ct = cancellationTokenAsync let resultCell = new ResultCell<_>() @@ -1820,37 +2066,45 @@ type Async = let latch = Latch() let mutable registration: CancellationTokenRegistration option = None let mutable del: 'Delegate option = None - registration <- - ct.Register(Action(fun () -> - if latch.Enter() then - // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration - - // Stop listening to events - RemoveHandler event &del - - // Call the given cancellation routine if we've been given one - // Exceptions from a cooperative cancellation are ignored. - match cancelAction with - | None -> () - | Some cancel -> - try cancel() with _ -> () - - // Register the cancellation result. - resultCell.RegisterResult(Canceled (OperationCanceledException ct), reuseThread=true) |> unfake - )) |> Some + + registration <- + ct.Register( + Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration + + // Stop listening to events + RemoveHandler event &del + + // Call the given cancellation routine if we've been given one + // Exceptions from a cooperative cancellation are ignored. + match cancelAction with + | None -> () + | Some cancel -> + try + cancel () + with _ -> + () + + // Register the cancellation result. + resultCell.RegisterResult(Canceled(OperationCanceledException ct), reuseThread = true) + |> unfake) + ) + |> Some let del = - FuncDelegate<'T>.Create<'Delegate>(fun eventArgs -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + FuncDelegate<'T> + .Create<'Delegate>(fun eventArgs -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration - // Stop listening to events - RemoveHandler event &del + // Stop listening to events + RemoveHandler event &del - // Register the successful result. - resultCell.RegisterResult(Ok eventArgs, reuseThread=true) |> unfake) + // Register the successful result. + resultCell.RegisterResult(Ok eventArgs, reuseThread = true) |> unfake) // Start listening to events event.AddHandler del @@ -1858,63 +2112,87 @@ type Async = // Return the async computation that allows us to await the result // Note: ok to use "NoDirectCancel" here because cancellation has been registered above // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method - return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } + return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell + } - static member Ignore (computation: Async<'T>) = CreateIgnoreAsync computation + static member Ignore(computation: Async<'T>) = + CreateIgnoreAsync computation - static member SwitchToNewThread() = CreateSwitchToNewThreadAsync() + static member SwitchToNewThread() = + CreateSwitchToNewThreadAsync() - static member SwitchToThreadPool() = CreateSwitchToThreadPoolAsync() + static member SwitchToThreadPool() = + CreateSwitchToThreadPoolAsync() - static member StartChild (computation:Async<'T>, ?millisecondsTimeout) = + static member StartChild(computation: Async<'T>, ?millisecondsTimeout) = async { let resultCell = new ResultCell<_>() let! ct = cancellationTokenAsync let innerCTS = new CancellationTokenSource() // innerCTS does not require disposal let mutable ctsRef = innerCTS - let registration = - ct.Register(Action(fun () -> - match ctsRef with - | null -> () - | otherwise -> otherwise.Cancel())) - do QueueAsync - innerCTS.Token - // since innerCTS is not ever Disposed, can call reg.Dispose() without a safety Latch - (fun res -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Ok res, reuseThread=true)) - (fun edi -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Error edi, reuseThread=true)) - (fun err -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Canceled err, reuseThread=true)) - computation - |> unfake + let registration = + ct.Register( + Action(fun () -> + match ctsRef with + | null -> () + | otherwise -> otherwise.Cancel()) + ) - return Async.AwaitAndBindChildResult(innerCTS, resultCell, millisecondsTimeout) } + do + QueueAsync + innerCTS.Token + // since innerCTS is not ever Disposed, can call reg.Dispose() without a safety Latch + (fun res -> + ctsRef <- null + registration.Dispose() + resultCell.RegisterResult(Ok res, reuseThread = true)) + (fun edi -> + ctsRef <- null + registration.Dispose() + resultCell.RegisterResult(Error edi, reuseThread = true)) + (fun err -> + ctsRef <- null + registration.Dispose() + resultCell.RegisterResult(Canceled err, reuseThread = true)) + computation + |> unfake + + return Async.AwaitAndBindChildResult(innerCTS, resultCell, millisecondsTimeout) + } static member SwitchToContext syncContext = - async { + async { match syncContext with | null -> // no synchronization context, just switch to the thread pool do! Async.SwitchToThreadPool() | syncCtxt -> // post the continuation to the synchronization context - return! CreateSwitchToAsync syncCtxt + return! CreateSwitchToAsync syncCtxt } static member OnCancel interruption = - async { + async { let! ct = cancellationTokenAsync // latch protects cancellation and disposal contention let latch = Latch() let mutable registration: CancellationTokenRegistration option = None + registration <- - ct.Register(Action(fun () -> + ct.Register( + Action(fun () -> if latch.Enter() then // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration + DisposeCancellationRegistration ®istration + try interruption () - with _ -> ())) + with _ -> + ()) + ) |> Some + let disposer = { new System.IDisposable with member _.Dispose() = @@ -1923,32 +2201,34 @@ type Async = if not ct.IsCancellationRequested then if latch.Enter() then // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration } + DisposeCancellationRegistration ®istration + } + return disposer } - static member TryCancelled (computation: Async<'T>, compensation) = + static member TryCancelled(computation: Async<'T>, compensation) = CreateWhenCancelledAsync compensation computation - static member AwaitTask (task:Task<'T>) : Async<'T> = - MakeAsyncWithCancelCheck (fun ctxt -> + static member AwaitTask(task: Task<'T>) : Async<'T> = + MakeAsyncWithCancelCheck(fun ctxt -> if task.IsCompleted then // Run synchronously without installing new trampoline OnTaskCompleted task ctxt else // Continue asynchronously, via syncContext if necessary, installing new trampoline let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode (fun () -> AttachContinuationToTask task ctxt)) + ctxt.ProtectCode(fun () -> AttachContinuationToTask task ctxt)) - static member AwaitTask (task:Task) : Async = - MakeAsyncWithCancelCheck (fun ctxt -> + static member AwaitTask(task: Task) : Async = + MakeAsyncWithCancelCheck(fun ctxt -> if task.IsCompleted then // Continue synchronously without installing new trampoline OnUnitTaskCompleted task ctxt else // Continue asynchronously, via syncContext if necessary, installing new trampoline let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode (fun () -> AttachContinuationToUnitTask task ctxt)) + ctxt.ProtectCode(fun () -> AttachContinuationToUnitTask task ctxt)) module CommonExtensions = @@ -1957,80 +2237,100 @@ module CommonExtensions = [] // give the extension member a 'nice', unmangled compiled name, unique within this module member stream.AsyncRead(buffer: byte[], ?offset, ?count) = let offset = defaultArg offset 0 - let count = defaultArg count buffer.Length - Async.FromBeginEnd (buffer, offset, count, stream.BeginRead, stream.EndRead) + let count = defaultArg count buffer.Length + Async.FromBeginEnd(buffer, offset, count, stream.BeginRead, stream.EndRead) [] // give the extension member a 'nice', unmangled compiled name, unique within this module member stream.AsyncRead count = - async { + async { let buffer = Array.zeroCreate count let mutable i = 0 + while i < count do let! n = stream.AsyncRead(buffer, i, count - i) i <- i + n + if n = 0 then - raise(System.IO.EndOfStreamException(SR.GetString(SR.failedReadEnoughBytes))) - return buffer + raise (System.IO.EndOfStreamException(SR.GetString(SR.failedReadEnoughBytes))) + + return buffer } [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member stream.AsyncWrite(buffer:byte[], ?offset:int, ?count:int) = + member stream.AsyncWrite(buffer: byte[], ?offset: int, ?count: int) = let offset = defaultArg offset 0 - let count = defaultArg count buffer.Length - Async.FromBeginEnd (buffer, offset, count, stream.BeginWrite, stream.EndWrite) + let count = defaultArg count buffer.Length + Async.FromBeginEnd(buffer, offset, count, stream.BeginWrite, stream.EndWrite) type IObservable<'Args> with [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member x.Add(callback: 'Args -> unit) = x.Subscribe callback |> ignore + member x.Add(callback: 'Args -> unit) = + x.Subscribe callback |> ignore [] // give the extension member a 'nice', unmangled compiled name, unique within this module member x.Subscribe callback = - x.Subscribe { new IObserver<'Args> with - member x.OnNext args = callback args - member x.OnError e = () - member x.OnCompleted() = () } + x.Subscribe + { new IObserver<'Args> with + member x.OnNext args = + callback args + + member x.OnError e = + () + + member x.OnCompleted() = + () + } module WebExtensions = type System.Net.WebRequest with + [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member req.AsyncGetResponse() : Async= + member req.AsyncGetResponse() : Async = let mutable canceled = false // WebException with Status = WebExceptionStatus.RequestCanceled can be raised in other situations except cancellation, use flag to filter out false positives // Use CreateTryWithFilterAsync to allow propagation of exception without losing stack - Async.FromBeginEnd(beginAction=req.BeginGetResponse, - endAction = req.EndGetResponse, - cancelAction = fun() -> canceled <- true; req.Abort()) - |> CreateTryWithFilterAsync (fun exn -> + Async.FromBeginEnd( + beginAction = req.BeginGetResponse, + endAction = req.EndGetResponse, + cancelAction = + fun () -> + canceled <- true + req.Abort() + ) + |> CreateTryWithFilterAsync(fun exn -> match exn with - | :? System.Net.WebException as webExn - when webExn.Status = System.Net.WebExceptionStatus.RequestCanceled && canceled -> + | :? System.Net.WebException as webExn when + webExn.Status = System.Net.WebExceptionStatus.RequestCanceled && canceled + -> - Some (CreateAsyncResultAsync(AsyncResult.Canceled (OperationCanceledException webExn.Message))) - | _ -> - None) + Some(CreateAsyncResultAsync(AsyncResult.Canceled(OperationCanceledException webExn.Message))) + | _ -> None) type System.Net.WebClient with + member inline private this.Download(event: IEvent<'T, _>, handler: _ -> 'T, start, result) = let downloadAsync = - Async.FromContinuations (fun (cont, econt, ccont) -> - let userToken = obj() + Async.FromContinuations(fun (cont, econt, ccont) -> + let userToken = obj () + let rec delegate' (_: obj) (args: #ComponentModel.AsyncCompletedEventArgs) = // ensure we handle the completed event from correct download call if userToken = args.UserState then event.RemoveHandler handle + if args.Cancelled then ccont (OperationCanceledException()) elif isNotNull args.Error then econt args.Error else cont (result args) + and handle = handler delegate' event.AddHandler handle - start userToken - ) + start userToken) async { use! _holder = Async.OnCancel(fun _ -> this.CancelAsync()) @@ -2038,28 +2338,28 @@ module WebExtensions = } [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member this.AsyncDownloadString (address:Uri) : Async = + member this.AsyncDownloadString(address: Uri) : Async = this.Download( - event = this.DownloadStringCompleted, - handler = (fun action -> Net.DownloadStringCompletedEventHandler action), - start = (fun userToken -> this.DownloadStringAsync(address, userToken)), - result = (fun args -> args.Result) + event = this.DownloadStringCompleted, + handler = (fun action -> Net.DownloadStringCompletedEventHandler action), + start = (fun userToken -> this.DownloadStringAsync(address, userToken)), + result = (fun args -> args.Result) ) [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member this.AsyncDownloadData (address:Uri) : Async = + member this.AsyncDownloadData(address: Uri) : Async = this.Download( - event = this.DownloadDataCompleted, - handler = (fun action -> Net.DownloadDataCompletedEventHandler action), - start = (fun userToken -> this.DownloadDataAsync(address, userToken)), - result = (fun args -> args.Result) + event = this.DownloadDataCompleted, + handler = (fun action -> Net.DownloadDataCompletedEventHandler action), + start = (fun userToken -> this.DownloadDataAsync(address, userToken)), + result = (fun args -> args.Result) ) [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member this.AsyncDownloadFile (address:Uri, fileName:string) : Async = + member this.AsyncDownloadFile(address: Uri, fileName: string) : Async = this.Download( - event = this.DownloadFileCompleted, - handler = (fun action -> ComponentModel.AsyncCompletedEventHandler action), - start = (fun userToken -> this.DownloadFileAsync(address, fileName, userToken)), - result = (fun _ -> ()) + event = this.DownloadFileCompleted, + handler = (fun action -> ComponentModel.AsyncCompletedEventHandler action), + start = (fun userToken -> this.DownloadFileAsync(address, fileName, userToken)), + result = (fun _ -> ()) ) diff --git a/src/FSharp.Core/collections.fs b/src/FSharp.Core/collections.fs index b08a1989622..fe26460fbc5 100644 --- a/src/FSharp.Core/collections.fs +++ b/src/FSharp.Core/collections.fs @@ -8,41 +8,59 @@ open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators open System.Collections.Generic -module HashIdentity = - - let inline Structural<'T when 'T : equality> : IEqualityComparer<'T> = +module HashIdentity = + + let inline Structural<'T when 'T: equality> : IEqualityComparer<'T> = LanguagePrimitives.FastGenericEqualityComparer<'T> - - let inline LimitedStructural<'T when 'T : equality>(limit) : IEqualityComparer<'T> = + + let inline LimitedStructural<'T when 'T: equality> (limit) : IEqualityComparer<'T> = LanguagePrimitives.FastLimitedGenericEqualityComparer<'T>(limit) - - let Reference<'T when 'T : not struct > : IEqualityComparer<'T> = + + let Reference<'T when 'T: not struct> : IEqualityComparer<'T> = + { new IEqualityComparer<'T> with + member _.GetHashCode(x) = + LanguagePrimitives.PhysicalHash(x) + + member _.Equals(x, y) = + LanguagePrimitives.PhysicalEquality x y + } + + let inline NonStructural<'T when 'T: equality and 'T: (static member (=): 'T * 'T -> bool)> = { new IEqualityComparer<'T> with - member _.GetHashCode(x) = LanguagePrimitives.PhysicalHash(x) - member _.Equals(x,y) = LanguagePrimitives.PhysicalEquality x y } + member _.GetHashCode(x) = + NonStructuralComparison.hash x + + member _.Equals(x, y) = + NonStructuralComparison.(=) x y + } + + let inline FromFunctions hasher equality : IEqualityComparer<'T> = + let eq = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (equality) - let inline NonStructural< 'T when 'T : equality and 'T : (static member ( = ) : 'T * 'T -> bool) > = { new IEqualityComparer<'T> with - member _.GetHashCode(x) = NonStructuralComparison.hash x - member _.Equals(x, y) = NonStructuralComparison.(=) x y } + member _.GetHashCode(x) = + hasher x - let inline FromFunctions hasher equality : IEqualityComparer<'T> = - let eq = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(equality) - { new IEqualityComparer<'T> with - member _.GetHashCode(x) = hasher x - member _.Equals(x,y) = eq.Invoke(x,y) } + member _.Equals(x, y) = + eq.Invoke(x, y) + } -module ComparisonIdentity = +module ComparisonIdentity = - let inline Structural<'T when 'T : comparison > : IComparer<'T> = + let inline Structural<'T when 'T: comparison> : IComparer<'T> = LanguagePrimitives.FastGenericComparer<'T> - let inline NonStructural< 'T when 'T : (static member ( < ) : 'T * 'T -> bool) and 'T : (static member ( > ) : 'T * 'T -> bool) > : IComparer<'T> = + let inline NonStructural<'T + when 'T: (static member (<): 'T * 'T -> bool) and 'T: (static member (>): 'T * 'T -> bool)> : IComparer<'T> = { new IComparer<'T> with - member _.Compare(x,y) = NonStructuralComparison.compare x y } + member _.Compare(x, y) = + NonStructuralComparison.compare x y + } - let FromFunction comparer = - let comparer = OptimizedClosures.FSharpFunc<'T,'T,int>.Adapt(comparer) - { new IComparer<'T> with - member _.Compare(x,y) = comparer.Invoke(x,y) } + let FromFunction comparer = + let comparer = OptimizedClosures.FSharpFunc<'T, 'T, int>.Adapt (comparer) + { new IComparer<'T> with + member _.Compare(x, y) = + comparer.Invoke(x, y) + } diff --git a/src/FSharp.Core/event.fs b/src/FSharp.Core/event.fs index 054b31cbd0b..300434cdc97 100644 --- a/src/FSharp.Core/event.fs +++ b/src/FSharp.Core/event.fs @@ -8,8 +8,9 @@ open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Core.Operators open Microsoft.FSharp.Collections open Microsoft.FSharp.Control -open System.Reflection +open System open System.Diagnostics +open System.Reflection module private Atomic = open System.Threading @@ -17,138 +18,179 @@ module private Atomic = let inline setWith (thunk: 'a -> 'a) (value: byref<'a>) = let mutable exchanged = false let mutable oldValue = value + while not exchanged do let comparand = oldValue let newValue = thunk comparand oldValue <- Interlocked.CompareExchange(&value, newValue, comparand) + if obj.ReferenceEquals(comparand, oldValue) then exchanged <- true [] -type DelegateEvent<'Delegate when 'Delegate :> System.Delegate>() = - let mutable multicast : System.Delegate = null - member x.Trigger(args:obj[]) = - match multicast with +type DelegateEvent<'Delegate when 'Delegate :> System.Delegate>() = + let mutable multicast: System.Delegate = null + + member x.Trigger(args: obj[]) = + match multicast with | null -> () | d -> d.DynamicInvoke(args) |> ignore - member x.Publish = - { new IDelegateEvent<'Delegate> with + + member x.Publish = + { new IDelegateEvent<'Delegate> with member x.AddHandler(d) = Atomic.setWith (fun value -> System.Delegate.Combine(value, d)) &multicast + member x.RemoveHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Remove(value, d)) &multicast } + Atomic.setWith (fun value -> System.Delegate.Remove(value, d)) &multicast + } type EventDelegee<'Args>(observer: System.IObserver<'Args>) = - static let makeTuple = + static let makeTuple = if Microsoft.FSharp.Reflection.FSharpType.IsTuple(typeof<'Args>) then Microsoft.FSharp.Reflection.FSharpValue.PreComputeTupleConstructor(typeof<'Args>) else - fun _ -> assert false; null // should not be called, one-argument case don't use makeTuple function + fun _ -> + assert false + null // should not be called, one-argument case don't use makeTuple function - member x.Invoke(_sender:obj, args: 'Args) = - observer.OnNext args - member x.Invoke(_sender:obj, a, b) = - let args = makeTuple([|a; b|]) :?> 'Args + member x.Invoke(_sender: obj, args: 'Args) = observer.OnNext args - member x.Invoke(_sender:obj, a, b, c) = - let args = makeTuple([|a; b; c|]) :?> 'Args + + member x.Invoke(_sender: obj, a, b) = + let args = makeTuple ([| a; b |]) :?> 'Args observer.OnNext args - member x.Invoke(_sender:obj, a, b, c, d) = - let args = makeTuple([|a; b; c; d|]) :?> 'Args + + member x.Invoke(_sender: obj, a, b, c) = + let args = makeTuple ([| a; b; c |]) :?> 'Args observer.OnNext args - member x.Invoke(_sender:obj, a, b, c, d, e) = - let args = makeTuple([|a; b; c; d; e|]) :?> 'Args + + member x.Invoke(_sender: obj, a, b, c, d) = + let args = makeTuple ([| a; b; c; d |]) :?> 'Args observer.OnNext args - member x.Invoke(_sender:obj, a, b, c, d, e, f) = - let args = makeTuple([|a; b; c; d; e; f|]) :?> 'Args + + member x.Invoke(_sender: obj, a, b, c, d, e) = + let args = makeTuple ([| a; b; c; d; e |]) :?> 'Args observer.OnNext args + member x.Invoke(_sender: obj, a, b, c, d, e, f) = + let args = makeTuple ([| a; b; c; d; e; f |]) :?> 'Args + observer.OnNext args -type EventWrapper<'Delegate,'Args> = delegate of 'Delegate * obj * 'Args -> unit +type EventWrapper<'Delegate, 'Args> = delegate of 'Delegate * obj * 'Args -> unit [] -type Event<'Delegate, 'Args when 'Delegate : delegate<'Args, unit> and 'Delegate :> System.Delegate and 'Delegate: not struct>() = +type Event<'Delegate, 'Args + when 'Delegate: delegate<'Args, unit> and 'Delegate :> System.Delegate and 'Delegate: not struct>() = + + let mutable multicast: 'Delegate = Unchecked.defaultof<_> - let mutable multicast : 'Delegate = Unchecked.defaultof<_> + static let mi, argTypes = + let instanceBindingFlags = + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.DeclaredOnly - static let mi, argTypes = - let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly - let mi = typeof<'Delegate>.GetMethod("Invoke",instanceBindingFlags) + let mi = typeof<'Delegate>.GetMethod ("Invoke", instanceBindingFlags) let actualTypes = mi.GetParameters() |> Array.map (fun p -> p.ParameterType) mi, actualTypes.[1..] - // For the one-argument case, use an optimization that allows a fast call. + // For the one-argument case, use an optimization that allows a fast call. // CreateDelegate creates a delegate that is fast to invoke. - static let invoker = - if argTypes.Length = 1 then - (System.Delegate.CreateDelegate(typeof>, mi) :?> EventWrapper<'Delegate,'Args>) + static let invoker = + if argTypes.Length = 1 then + (Delegate.CreateDelegate(typeof>, mi) :?> EventWrapper<'Delegate, 'Args>) else null // For the multi-arg case, use a slower DynamicInvoke. static let invokeInfo = - let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly - let mi = - typeof>.GetMethods(instanceBindingFlags) - |> Seq.filter(fun mi -> mi.Name = "Invoke" && mi.GetParameters().Length = argTypes.Length + 1) + let instanceBindingFlags = + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.DeclaredOnly + + let mi = + typeof>.GetMethods (instanceBindingFlags) + |> Seq.filter (fun mi -> mi.Name = "Invoke" && mi.GetParameters().Length = argTypes.Length + 1) |> Seq.exactlyOne + if mi.IsGenericMethodDefinition then mi.MakeGenericMethod argTypes - else - mi + else + mi - member x.Trigger(sender:obj,args: 'Args) = - // Copy multicast value into local variable to avoid changing during member call. + member x.Trigger(sender: obj, args: 'Args) = + // Copy multicast value into local variable to avoid changing during member call. let multicast = multicast - match box multicast with - | null -> () - | _ -> - match invoker with - | null -> - let args = Array.append [| sender |] (Microsoft.FSharp.Reflection.FSharpValue.GetTupleFields(box args)) + + match box multicast with + | null -> () + | _ -> + match invoker with + | null -> + let args = + Array.append [| sender |] (Microsoft.FSharp.Reflection.FSharpValue.GetTupleFields(box args)) + multicast.DynamicInvoke(args) |> ignore - | _ -> - // For the one-argument case, use an optimization that allows a fast call. + | _ -> + // For the one-argument case, use an optimization that allows a fast call. // CreateDelegate creates a delegate that is fast to invoke. invoker.Invoke(multicast, sender, args) |> ignore member x.Publish = { new obj() with - member x.ToString() = "" - interface IEvent<'Delegate,'Args> with - member e.AddHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> 'Delegate) &multicast - member e.RemoveHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> 'Delegate) &multicast - interface System.IObservable<'Args> with - member e.Subscribe(observer) = - let obj = new EventDelegee<'Args>(observer) - let h = System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeInfo) :?> 'Delegate - (e :?> IDelegateEvent<'Delegate>).AddHandler(h) - { new System.IDisposable with - member x.Dispose() = (e :?> IDelegateEvent<'Delegate>).RemoveHandler(h) } } + member x.ToString() = + "" + interface IEvent<'Delegate, 'Args> with + member e.AddHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> 'Delegate) &multicast + + member e.RemoveHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> 'Delegate) &multicast + interface System.IObservable<'Args> with + member e.Subscribe(observer) = + let obj = new EventDelegee<'Args>(observer) + let h = Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeInfo) :?> 'Delegate + + (e :?> IDelegateEvent<'Delegate>).AddHandler(h) + + { new System.IDisposable with + member x.Dispose() = + (e :?> IDelegateEvent<'Delegate>).RemoveHandler(h) + } + } [] -type Event<'T> = - val mutable multicast : Handler<'T> +type Event<'T> = + val mutable multicast: Handler<'T> new() = { multicast = null } - member x.Trigger(arg:'T) = - match x.multicast with + member x.Trigger(arg: 'T) = + match x.multicast with | null -> () - | d -> d.Invoke(null,arg) |> ignore + | d -> d.Invoke(null, arg) |> ignore + member x.Publish = { new obj() with - member x.ToString() = "" - interface IEvent<'T> with - member e.AddHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> Handler<'T>) &x.multicast - member e.RemoveHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> Handler<'T>) &x.multicast - interface System.IObservable<'T> with - member e.Subscribe(observer) = - let h = new Handler<_>(fun sender args -> observer.OnNext(args)) - (e :?> IEvent<_,_>).AddHandler(h) - { new System.IDisposable with - member x.Dispose() = (e :?> IEvent<_,_>).RemoveHandler(h) } } + member x.ToString() = + "" + interface IEvent<'T> with + member e.AddHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> Handler<'T>) &x.multicast + + member e.RemoveHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> Handler<'T>) &x.multicast + interface System.IObservable<'T> with + member e.Subscribe(observer) = + let h = new Handler<_>(fun sender args -> observer.OnNext(args)) + (e :?> IEvent<_, _>).AddHandler(h) + + { new System.IDisposable with + member x.Dispose() = + (e :?> IEvent<_, _>).RemoveHandler(h) + } + } diff --git a/src/FSharp.Core/event.fsi b/src/FSharp.Core/event.fsi index 536b414ba54..12557f0dc22 100644 --- a/src/FSharp.Core/event.fsi +++ b/src/FSharp.Core/event.fsi @@ -34,7 +34,8 @@ type DelegateEvent<'Delegate when 'Delegate :> System.Delegate> = /// /// Events and Observables [] -type Event<'Delegate, 'Args when 'Delegate: delegate<'Args, unit> and 'Delegate :> System.Delegate and 'Delegate: not struct> = +type Event<'Delegate, 'Args + when 'Delegate: delegate<'Args, unit> and 'Delegate :> System.Delegate and 'Delegate: not struct> = /// Creates an event object suitable for delegate types following the standard .NET Framework convention of a first 'sender' argument. /// The created event. diff --git a/src/FSharp.Core/eventmodule.fs b/src/FSharp.Core/eventmodule.fs index b9776a692d9..cd9dc68a76d 100644 --- a/src/FSharp.Core/eventmodule.fs +++ b/src/FSharp.Core/eventmodule.fs @@ -9,73 +9,92 @@ open Microsoft.FSharp.Control [] module Event = [] - let create<'T>() = - let ev = new Event<'T>() + let create<'T> () = + let ev = new Event<'T>() ev.Trigger, ev.Publish [] - let map mapping (sourceEvent: IEvent<'Delegate,'T>) = - let ev = new Event<_>() + let map mapping (sourceEvent: IEvent<'Delegate, 'T>) = + let ev = new Event<_>() sourceEvent.Add(fun x -> ev.Trigger(mapping x)) ev.Publish [] - let filter predicate (sourceEvent: IEvent<'Delegate,'T>) = - let ev = new Event<_>() + let filter predicate (sourceEvent: IEvent<'Delegate, 'T>) = + let ev = new Event<_>() sourceEvent.Add(fun x -> if predicate x then ev.Trigger x) ev.Publish [] - let partition predicate (sourceEvent: IEvent<'Delegate,'T>) = - let ev1 = new Event<_>() - let ev2 = new Event<_>() - sourceEvent.Add(fun x -> if predicate x then ev1.Trigger x else ev2.Trigger x) - ev1.Publish,ev2.Publish + let partition predicate (sourceEvent: IEvent<'Delegate, 'T>) = + let ev1 = new Event<_>() + let ev2 = new Event<_>() + + sourceEvent.Add(fun x -> + if predicate x then + ev1.Trigger x + else + ev2.Trigger x) + + ev1.Publish, ev2.Publish [] - let choose chooser (sourceEvent: IEvent<'Delegate,'T>) = - let ev = new Event<_>() - sourceEvent.Add(fun x -> match chooser x with None -> () | Some r -> ev.Trigger r) + let choose chooser (sourceEvent: IEvent<'Delegate, 'T>) = + let ev = new Event<_>() + + sourceEvent.Add(fun x -> + match chooser x with + | None -> () + | Some r -> ev.Trigger r) + ev.Publish [] - let scan collector state (sourceEvent: IEvent<'Delegate,'T>) = + let scan collector state (sourceEvent: IEvent<'Delegate, 'T>) = let mutable state = state - let ev = new Event<_>() + let ev = new Event<_>() + sourceEvent.Add(fun msg -> - let z = state - let z = collector z msg - state <- z; - ev.Trigger(z)) + let z = state + let z = collector z msg + state <- z + ev.Trigger(z)) + ev.Publish [] - let add callback (sourceEvent: IEvent<'Delegate,'T>) = sourceEvent.Add(callback) + let add callback (sourceEvent: IEvent<'Delegate, 'T>) = + sourceEvent.Add(callback) [] - let pairwise (sourceEvent : IEvent<'Delegate,'T>) : IEvent<'T * 'T> = - let ev = new Event<'T * 'T>() + let pairwise (sourceEvent: IEvent<'Delegate, 'T>) : IEvent<'T * 'T> = + let ev = new Event<'T * 'T>() let mutable lastArgs = None - sourceEvent.Add(fun args2 -> - (match lastArgs with - | None -> () - | Some args1 -> ev.Trigger(args1,args2)) + + sourceEvent.Add(fun args2 -> + (match lastArgs with + | None -> () + | Some args1 -> ev.Trigger(args1, args2)) + lastArgs <- Some args2) ev.Publish [] - let merge (event1: IEvent<'Del1,'T>) (event2: IEvent<'Del2,'T>) = - let ev = new Event<_>() + let merge (event1: IEvent<'Del1, 'T>) (event2: IEvent<'Del2, 'T>) = + let ev = new Event<_>() event1.Add(fun x -> ev.Trigger(x)) event2.Add(fun x -> ev.Trigger(x)) ev.Publish [] - let split (splitter : 'T -> Choice<'U1,'U2>) (sourceEvent: IEvent<'Delegate,'T>) = - let ev1 = new Event<_>() - let ev2 = new Event<_>() - sourceEvent.Add(fun x -> match splitter x with Choice1Of2 y -> ev1.Trigger(y) | Choice2Of2 z -> ev2.Trigger(z)) - ev1.Publish,ev2.Publish + let split (splitter: 'T -> Choice<'U1, 'U2>) (sourceEvent: IEvent<'Delegate, 'T>) = + let ev1 = new Event<_>() + let ev2 = new Event<_>() + sourceEvent.Add(fun x -> + match splitter x with + | Choice1Of2 y -> ev1.Trigger(y) + | Choice2Of2 z -> ev2.Trigger(z)) + ev1.Publish, ev2.Publish diff --git a/src/FSharp.Core/fslib-extra-pervasives.fs b/src/FSharp.Core/fslib-extra-pervasives.fs index 2c0c462a9bc..c78b71e48e0 100644 --- a/src/FSharp.Core/fslib-extra-pervasives.fs +++ b/src/FSharp.Core/fslib-extra-pervasives.fs @@ -16,112 +16,145 @@ module ExtraTopLevelOperators = open Microsoft.FSharp.Primitives.Basics open Microsoft.FSharp.Core.CompilerServices - let inline checkNonNullNullArg argName arg = - match box arg with - | null -> nullArg argName + let inline checkNonNullNullArg argName arg = + match box arg with + | null -> nullArg argName | _ -> () - let inline checkNonNullInvalidArg argName message arg = - match box arg with + let inline checkNonNullInvalidArg argName message arg = + match box arg with | null -> invalidArg argName message | _ -> () [] - let set elements = Collections.Set.ofSeq elements + let set elements = + Collections.Set.ofSeq elements let dummyArray = [||] - let inline dont_tail_call f = + + let inline dont_tail_call f = let result = f () dummyArray.Length |> ignore // pretty stupid way to avoid tail call, would be better if attribute existed, but this should be inlineable by the JIT result - let inline ICollection_Contains<'collection,'item when 'collection :> ICollection<'item>> (collection:'collection) (item:'item) = + let inline ICollection_Contains<'collection, 'item when 'collection :> ICollection<'item>> + (collection: 'collection) + (item: 'item) + = collection.Contains item [] - [>)>] - type DictImpl<'SafeKey,'Key,'T>(t : Dictionary<'SafeKey,'T>, makeSafeKey : 'Key->'SafeKey, getKey : 'SafeKey->'Key) = + [>)>] + type DictImpl<'SafeKey, 'Key, 'T> + ( + t: Dictionary<'SafeKey, 'T>, + makeSafeKey: 'Key -> 'SafeKey, + getKey: 'SafeKey -> 'Key + ) = #if NETSTANDARD - static let emptyEnumerator = (Array.empty> :> seq<_>).GetEnumerator() + static let emptyEnumerator = + (Array.empty> :> seq<_>).GetEnumerator() #endif member _.Count = t.Count // Give a read-only view of the dictionary interface IDictionary<'Key, 'T> with - member _.Item + member _.Item with get x = dont_tail_call (fun () -> t.[makeSafeKey x]) - and set _ _ = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + and set _ _ = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Keys = + member _.Keys = let keys = t.Keys - { new ICollection<'Key> with - member _.Add(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + { new ICollection<'Key> with + member _.Add(x) = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Remove(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member _.Clear() = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Contains(x) = t.ContainsKey (makeSafeKey x) + member _.Remove(x) = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.CopyTo(arr,i) = - let mutable n = 0 - for k in keys do - arr.[i+n] <- getKey k - n <- n + 1 + member _.Contains(x) = + t.ContainsKey(makeSafeKey x) - member _.IsReadOnly = true + member _.CopyTo(arr, i) = + let mutable n = 0 - member _.Count = keys.Count + for k in keys do + arr.[i + n] <- getKey k + n <- n + 1 - interface IEnumerable<'Key> with - member _.GetEnumerator() = (keys |> Seq.map getKey).GetEnumerator() + member _.IsReadOnly = true + member _.Count = keys.Count + interface IEnumerable<'Key> with + member _.GetEnumerator() = + (keys |> Seq.map getKey).GetEnumerator() interface System.Collections.IEnumerable with - member _.GetEnumerator() = ((keys |> Seq.map getKey) :> System.Collections.IEnumerable).GetEnumerator() } - + member _.GetEnumerator() = + ((keys |> Seq.map getKey) :> System.Collections.IEnumerable).GetEnumerator() + } + member _.Values = upcast t.Values - member _.Add(_,_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member _.Add(_, _) = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.ContainsKey(k) = dont_tail_call (fun () -> t.ContainsKey(makeSafeKey k)) + member _.ContainsKey(k) = + dont_tail_call (fun () -> t.ContainsKey(makeSafeKey k)) - member _.TryGetValue(k,r) = + member _.TryGetValue(k, r) = let safeKey = makeSafeKey k - if t.ContainsKey(safeKey) then (r <- t.[safeKey]; true) else false - member _.Remove(_ : 'Key) = (raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) : bool) + if t.ContainsKey(safeKey) then + (r <- t.[safeKey] + true) + else + false + + member _.Remove(_: 'Key) = + (raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))): bool) interface IReadOnlyDictionary<'Key, 'T> with - member _.Item with get key = t.[makeSafeKey key] + member _.Item + with get key = t.[makeSafeKey key] member _.Keys = t.Keys |> Seq.map getKey member _.TryGetValue(key, r) = - match t.TryGetValue (makeSafeKey key) with + match t.TryGetValue(makeSafeKey key) with | false, _ -> false | true, value -> r <- value true - member _.Values = (t :> IReadOnlyDictionary<_,_>).Values + member _.Values = (t :> IReadOnlyDictionary<_, _>).Values + + member _.ContainsKey k = + t.ContainsKey(makeSafeKey k) - member _.ContainsKey k = t.ContainsKey (makeSafeKey k) + interface ICollection> with - interface ICollection> with + member _.Add(_) = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Add(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member _.Clear() = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member _.Remove(_) = + raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member _.Remove(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member _.Contains(KeyValue (k, v)) = + ICollection_Contains t (KeyValuePair<_, _>(makeSafeKey k, v)) - member _.Contains(KeyValue(k,v)) = ICollection_Contains t (KeyValuePair<_,_>(makeSafeKey k,v)) + member _.CopyTo(arr, i) = + let mutable n = 0 - member _.CopyTo(arr,i) = - let mutable n = 0 - for (KeyValue(k,v)) in t do - arr.[i+n] <- KeyValuePair<_,_>(getKey k,v) + for (KeyValue (k, v)) in t do + arr.[i + n] <- KeyValuePair<_, _>(getKey k, v) n <- n + 1 member _.IsReadOnly = true @@ -135,104 +168,129 @@ module ExtraTopLevelOperators = member _.GetEnumerator() = // We use an array comprehension here instead of seq {} as otherwise we get incorrect - // IEnumerator.Reset() and IEnumerator.Current semantics. + // IEnumerator.Reset() and IEnumerator.Current semantics. // Coreclr has a bug with SZGenericEnumerators --- implement a correct enumerator. On desktop use the desktop implementation because it's ngened. -#if !NETSTANDARD - let kvps = [| for (KeyValue (k,v)) in t -> KeyValuePair (getKey k, v) |] :> seq<_> +#if !NETSTANDARD + let kvps = [| for (KeyValue (k, v)) in t -> KeyValuePair(getKey k, v) |] :> seq<_> kvps.GetEnumerator() #else let endIndex = t.Count - if endIndex = 0 then emptyEnumerator + + if endIndex = 0 then + emptyEnumerator else - let kvps = [| for (KeyValue (k,v)) in t -> KeyValuePair (getKey k, v) |] + let kvps = [| for (KeyValue (k, v)) in t -> KeyValuePair(getKey k, v) |] let mutable index = -1 + let current () = - if index < 0 then raise <| InvalidOperationException(SR.GetString(SR.enumerationNotStarted)) - if index >= endIndex then raise <| InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished)) + if index < 0 then + raise <| InvalidOperationException(SR.GetString(SR.enumerationNotStarted)) + + if index >= endIndex then + raise <| InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished)) + kvps.[index] - {new IEnumerator<_> with + { new IEnumerator<_> with member _.Current = current () - interface System.Collections.IEnumerator with - member _.Current = box(current()) - - member _.MoveNext() = - if index < endIndex then - index <- index + 1 - index < endIndex - else false - - member _.Reset() = index <- -1 - - interface System.IDisposable with - member _.Dispose() = () } + member _.Current = box (current ()) + + member _.MoveNext() = + if index < endIndex then + index <- index + 1 + index < endIndex + else + false + + member _.Reset() = + index <- -1 + interface System.IDisposable with + member _.Dispose() = + () + } #endif interface System.Collections.IEnumerable with member _.GetEnumerator() = // We use an array comprehension here instead of seq {} as otherwise we get incorrect - // IEnumerator.Reset() and IEnumerator.Current semantics. - let kvps = [| for (KeyValue (k,v)) in t -> KeyValuePair (getKey k, v) |] :> System.Collections.IEnumerable + // IEnumerator.Reset() and IEnumerator.Current semantics. + let kvps = + [| for (KeyValue (k, v)) in t -> KeyValuePair(getKey k, v) |] :> System.Collections.IEnumerable + kvps.GetEnumerator() - and DictDebugView<'SafeKey,'Key,'T>(d:DictImpl<'SafeKey,'Key,'T>) = + and DictDebugView<'SafeKey, 'Key, 'T>(d: DictImpl<'SafeKey, 'Key, 'T>) = [] member _.Items = Array.ofSeq d - let inline dictImpl (comparer:IEqualityComparer<'SafeKey>) (makeSafeKey : 'Key->'SafeKey) (getKey : 'SafeKey->'Key) (l:seq<'Key*'T>) = + let inline dictImpl + (comparer: IEqualityComparer<'SafeKey>) + (makeSafeKey: 'Key -> 'SafeKey) + (getKey: 'SafeKey -> 'Key) + (l: seq<'Key * 'T>) + = let t = Dictionary comparer - for (k,v) in l do + + for (k, v) in l do t.[makeSafeKey k] <- v + DictImpl(t, makeSafeKey, getKey) // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let dictValueType (l:seq<'Key*'T>) = + let dictValueType (l: seq<'Key * 'T>) = dictImpl HashIdentity.Structural<'Key> id id l // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let dictRefType (l:seq<'Key*'T>) = + let dictRefType (l: seq<'Key * 'T>) = dictImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun k -> RuntimeHelpers.StructBox k) (fun sb -> sb.Value) l [] - let dict (keyValuePairs:seq<'Key*'T>) : IDictionary<'Key,'T> = + let dict (keyValuePairs: seq<'Key * 'T>) : IDictionary<'Key, 'T> = if typeof<'Key>.IsValueType then dictValueType keyValuePairs else dictRefType keyValuePairs [] - let readOnlyDict (keyValuePairs:seq<'Key*'T>) : IReadOnlyDictionary<'Key,'T> = + let readOnlyDict (keyValuePairs: seq<'Key * 'T>) : IReadOnlyDictionary<'Key, 'T> = if typeof<'Key>.IsValueType then dictValueType keyValuePairs else dictRefType keyValuePairs - let getArray (vals : seq<'T>) = + let getArray (vals: seq<'T>) = match vals with | :? ('T[]) as arr -> arr | _ -> Seq.toArray vals [] - let array2D (rows : seq<#seq<'T>>) = + let array2D (rows: seq<#seq<'T>>) = checkNonNullNullArg "rows" rows let rowsArr = getArray rows let m = rowsArr.Length - if m = 0 - then Array2D.zeroCreate<'T> 0 0 + + if m = 0 then + Array2D.zeroCreate<'T> 0 0 else checkNonNullInvalidArg "rows" (SR.GetString(SR.nullsNotAllowedInArray)) rowsArr.[0] let firstRowArr = getArray rowsArr.[0] let n = firstRowArr.Length let res = Array2D.zeroCreate<'T> m n - for j in 0..(n-1) do - res.[0,j] <- firstRowArr.[j] - for i in 1..(m-1) do + + for j in 0 .. (n - 1) do + res.[0, j] <- firstRowArr.[j] + + for i in 1 .. (m - 1) do checkNonNullInvalidArg "rows" (SR.GetString(SR.nullsNotAllowedInArray)) rowsArr.[i] let rowiArr = getArray rowsArr.[i] - if rowiArr.Length <> n then invalidArg "vals" (SR.GetString(SR.arraysHadDifferentLengths)) - for j in 0..(n-1) do - res.[i,j] <- rowiArr.[j] + + if rowiArr.Length <> n then + invalidArg "vals" (SR.GetString(SR.arraysHadDifferentLengths)) + + for j in 0 .. (n - 1) do + res.[i, j] <- rowiArr.[j] + res [] @@ -244,28 +302,28 @@ module ExtraTopLevelOperators = Printf.failwithf format [] - let fprintf (textWriter:TextWriter) format = - Printf.fprintf textWriter format + let fprintf (textWriter: TextWriter) format = + Printf.fprintf textWriter format [] - let fprintfn (textWriter:TextWriter) format = - Printf.fprintfn textWriter format - + let fprintfn (textWriter: TextWriter) format = + Printf.fprintfn textWriter format + [] let printf format = - Printf.printf format + Printf.printf format [] let eprintf format = - Printf.eprintf format + Printf.eprintf format [] let printfn format = - Printf.printfn format + Printf.printfn format [] let eprintfn format = - Printf.eprintfn format + Printf.eprintfn format [] let failwith s = @@ -275,167 +333,205 @@ module ExtraTopLevelOperators = let async = AsyncBuilder() [] - let inline single value = float32 value + let inline single value = + float32 value [] - let inline double value = float value + let inline double value = + float value [] - let inline uint8 value = byte value + let inline uint8 value = + byte value [] - let inline int8 value = sbyte value + let inline int8 value = + sbyte value - module Checked = + module Checked = [] - let inline uint8 value = Checked.byte value + let inline uint8 value = + Checked.byte value [] - let inline int8 value = Checked.sbyte value + let inline int8 value = + Checked.sbyte value [] - let (~%) (expression:Microsoft.FSharp.Quotations.Expr<'T>) : 'T = + let (~%) (expression: Microsoft.FSharp.Quotations.Expr<'T>) : 'T = ignore expression raise (InvalidOperationException(SR.GetString(SR.firstClassUsesOfSplice))) [] let (~%%) (expression: Microsoft.FSharp.Quotations.Expr) : 'T = ignore expression - raise (InvalidOperationException (SR.GetString(SR.firstClassUsesOfSplice))) + raise (InvalidOperationException(SR.GetString(SR.firstClassUsesOfSplice))) [] [] [] [] [] - #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE +#if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE [] [] [] - #endif +#endif [] [] - do() + do () [] - let (|Lazy|) (input:Lazy<_>) = + let (|Lazy|) (input: Lazy<_>) = input.Force() let query = Microsoft.FSharp.Linq.QueryBuilder() - namespace Microsoft.FSharp.Core.CompilerServices - open System - open System.Reflection - open Microsoft.FSharp.Core - open Microsoft.FSharp.Control - open Microsoft.FSharp.Quotations - - /// Represents the product of two measure expressions when returned as a generic argument of a provided type. - [] - type MeasureProduct<'Measure1, 'Measure2>() = class end - - /// Represents the inverse of a measure expressions when returned as a generic argument of a provided type. - [] - type MeasureInverse<'Measure> = class end - - /// Represents the '1' measure expression when returned as a generic argument of a provided type. - [] - type MeasureOne = class end - - [] - type TypeProviderAttribute() = - inherit System.Attribute() +open System +open System.Reflection +open Microsoft.FSharp.Core +open Microsoft.FSharp.Control +open Microsoft.FSharp.Quotations + +/// Represents the product of two measure expressions when returned as a generic argument of a provided type. +[] +type MeasureProduct<'Measure1, 'Measure2>() = + class + end + +/// Represents the inverse of a measure expressions when returned as a generic argument of a provided type. +[] +type MeasureInverse<'Measure> = + class + end + +/// Represents the '1' measure expression when returned as a generic argument of a provided type. +[] +type MeasureOne = + class + end + +[] +type TypeProviderAttribute() = + inherit System.Attribute() - [] - type TypeProviderAssemblyAttribute(assemblyName : string) = - inherit System.Attribute() - new () = TypeProviderAssemblyAttribute(null) +[] +type TypeProviderAssemblyAttribute(assemblyName: string) = + inherit System.Attribute() + new() = TypeProviderAssemblyAttribute(null) - member _.AssemblyName = assemblyName + member _.AssemblyName = assemblyName - [] - type TypeProviderXmlDocAttribute(commentText: string) = - inherit System.Attribute() +[] +type TypeProviderXmlDocAttribute(commentText: string) = + inherit System.Attribute() - member _.CommentText = commentText + member _.CommentText = commentText - [] - type TypeProviderDefinitionLocationAttribute() = - inherit System.Attribute() - let mutable filePath : string = null - let mutable line : int = 0 - let mutable column : int = 0 +[] +type TypeProviderDefinitionLocationAttribute() = + inherit System.Attribute() + let mutable filePath: string = null + let mutable line: int = 0 + let mutable column: int = 0 - member _.FilePath with get() = filePath and set v = filePath <- v + member _.FilePath + with get () = filePath + and set v = filePath <- v - member _.Line with get() = line and set v = line <- v + member _.Line + with get () = line + and set v = line <- v - member _.Column with get() = column and set v = column <- v + member _.Column + with get () = column + and set v = column <- v - [] - type TypeProviderEditorHideMethodsAttribute() = - inherit System.Attribute() +[] +type TypeProviderEditorHideMethodsAttribute() = + inherit System.Attribute() - /// Additional type attribute flags related to provided types - type TypeProviderTypeAttributes = - | SuppressRelocate = 0x80000000 - | IsErased = 0x40000000 +/// Additional type attribute flags related to provided types +type TypeProviderTypeAttributes = + | SuppressRelocate = 0x80000000 + | IsErased = 0x40000000 - type TypeProviderConfig( systemRuntimeContainsType : string -> bool ) = - let mutable resolutionFolder: string = null - let mutable runtimeAssembly: string = null - let mutable referencedAssemblies: string[] = null - let mutable temporaryFolder: string = null - let mutable isInvalidationSupported: bool = false - let mutable useResolutionFolderAtRuntime: bool = false - let mutable systemRuntimeAssemblyVersion: System.Version = null +type TypeProviderConfig(systemRuntimeContainsType: string -> bool) = + let mutable resolutionFolder: string = null + let mutable runtimeAssembly: string = null + let mutable referencedAssemblies: string[] = null + let mutable temporaryFolder: string = null + let mutable isInvalidationSupported: bool = false + let mutable useResolutionFolderAtRuntime: bool = false + let mutable systemRuntimeAssemblyVersion: System.Version = null - member _.ResolutionFolder with get() = resolutionFolder and set v = resolutionFolder <- v + member _.ResolutionFolder + with get () = resolutionFolder + and set v = resolutionFolder <- v - member _.RuntimeAssembly with get() = runtimeAssembly and set v = runtimeAssembly <- v + member _.RuntimeAssembly + with get () = runtimeAssembly + and set v = runtimeAssembly <- v - member _.ReferencedAssemblies with get() = referencedAssemblies and set v = referencedAssemblies <- v + member _.ReferencedAssemblies + with get () = referencedAssemblies + and set v = referencedAssemblies <- v - member _.TemporaryFolder with get() = temporaryFolder and set v = temporaryFolder <- v + member _.TemporaryFolder + with get () = temporaryFolder + and set v = temporaryFolder <- v - member _.IsInvalidationSupported with get() = isInvalidationSupported and set v = isInvalidationSupported <- v + member _.IsInvalidationSupported + with get () = isInvalidationSupported + and set v = isInvalidationSupported <- v - member _.IsHostedExecution with get() = useResolutionFolderAtRuntime and set v = useResolutionFolderAtRuntime <- v + member _.IsHostedExecution + with get () = useResolutionFolderAtRuntime + and set v = useResolutionFolderAtRuntime <- v - member _.SystemRuntimeAssemblyVersion with get() = systemRuntimeAssemblyVersion and set v = systemRuntimeAssemblyVersion <- v + member _.SystemRuntimeAssemblyVersion + with get () = systemRuntimeAssemblyVersion + and set v = systemRuntimeAssemblyVersion <- v - member _.SystemRuntimeContainsType (typeName: string) = systemRuntimeContainsType typeName + member _.SystemRuntimeContainsType(typeName: string) = + systemRuntimeContainsType typeName - type IProvidedNamespace = +type IProvidedNamespace = - abstract NamespaceName: string + abstract NamespaceName: string - abstract GetNestedNamespaces: unit -> IProvidedNamespace[] + abstract GetNestedNamespaces: unit -> IProvidedNamespace[] - abstract GetTypes: unit -> Type[] + abstract GetTypes: unit -> Type[] - abstract ResolveTypeName: typeName: string -> Type + abstract ResolveTypeName: typeName: string -> Type - type ITypeProvider = - inherit System.IDisposable +type ITypeProvider = + inherit System.IDisposable - abstract GetNamespaces: unit -> IProvidedNamespace[] + abstract GetNamespaces: unit -> IProvidedNamespace[] - abstract GetStaticParameters: typeWithoutArguments: Type -> ParameterInfo[] + abstract GetStaticParameters: typeWithoutArguments: Type -> ParameterInfo[] - abstract ApplyStaticArguments: typeWithoutArguments: Type * typePathWithArguments: string[] * staticArguments:obj[] -> Type + abstract ApplyStaticArguments: + typeWithoutArguments: Type * typePathWithArguments: string[] * staticArguments: obj[] -> Type - abstract GetInvokerExpression: syntheticMethodBase:MethodBase * parameters:Expr[] -> Expr + abstract GetInvokerExpression: syntheticMethodBase: MethodBase * parameters: Expr[] -> Expr - [] - abstract Invalidate : IEvent - abstract GetGeneratedAssemblyContents: assembly:System.Reflection.Assembly -> byte[] + [] + abstract Invalidate: IEvent - type ITypeProvider2 = - abstract GetStaticParametersForMethod: methodWithoutArguments:MethodBase -> ParameterInfo[] + abstract GetGeneratedAssemblyContents: assembly: System.Reflection.Assembly -> byte[] - abstract ApplyStaticArgumentsForMethod: methodWithoutArguments:MethodBase * methodNameWithArguments:string * staticArguments:obj[] -> MethodBase +type ITypeProvider2 = + abstract GetStaticParametersForMethod: methodWithoutArguments: MethodBase -> ParameterInfo[] + abstract ApplyStaticArgumentsForMethod: + methodWithoutArguments: MethodBase * methodNameWithArguments: string * staticArguments: obj[] -> MethodBase diff --git a/src/FSharp.Core/list.fs b/src/FSharp.Core/list.fs index cd8b7ae3ad1..fbf8089610d 100644 --- a/src/FSharp.Core/list.fs +++ b/src/FSharp.Core/list.fs @@ -15,13 +15,14 @@ open System.Collections.Generic module List = let inline checkNonNull argName arg = - if isNull arg then - nullArg argName + if isNull arg then nullArg argName - let inline indexNotFound() = raise (KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) + let inline indexNotFound () = + raise (KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) [] - let length (list: 'T list) = list.Length + let length (list: 'T list) = + list.Length [] let last (list: 'T list) = @@ -33,170 +34,240 @@ module List = let rec tryLast (list: 'T list) = match Microsoft.FSharp.Primitives.Basics.List.tryLastV list with | ValueSome x -> Some x - | ValueNone -> None + | ValueNone -> None [] - let rev list = Microsoft.FSharp.Primitives.Basics.List.rev list + let rev list = + Microsoft.FSharp.Primitives.Basics.List.rev list [] - let concat lists = Microsoft.FSharp.Primitives.Basics.List.concat lists - - let inline countByImpl (comparer:IEqualityComparer<'SafeKey>) ([] projection: 'T->'SafeKey) ([] getKey:'SafeKey->'Key) (list: 'T list) = + let concat lists = + Microsoft.FSharp.Primitives.Basics.List.concat lists + + let inline countByImpl + (comparer: IEqualityComparer<'SafeKey>) + ([] projection: 'T -> 'SafeKey) + ([] getKey: 'SafeKey -> 'Key) + (list: 'T list) + = let dict = Dictionary comparer - let rec loop srcList = + + let rec loop srcList = match srcList with | [] -> () | h :: t -> let safeKey = projection h let mutable prev = 0 - if dict.TryGetValue(safeKey, &prev) then dict.[safeKey] <- prev + 1 else dict.[safeKey] <- 1 + + if dict.TryGetValue(safeKey, &prev) then + dict.[safeKey] <- prev + 1 + else + dict.[safeKey] <- 1 + loop t + loop list Microsoft.FSharp.Primitives.Basics.List.countBy dict getKey // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let countByValueType (projection: 'T->'Key) (list: 'T list) = countByImpl HashIdentity.Structural<'Key> projection id list + let countByValueType (projection: 'T -> 'Key) (list: 'T list) = + countByImpl HashIdentity.Structural<'Key> projection id list // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let countByRefType (projection: 'T->'Key) (list: 'T list) = countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (projection t)) (fun sb -> sb.Value) list + let countByRefType (projection: 'T -> 'Key) (list: 'T list) = + countByImpl + RuntimeHelpers.StructBox<'Key>.Comparer + (fun t -> RuntimeHelpers.StructBox(projection t)) + (fun sb -> sb.Value) + list [] - let countBy (projection: 'T->'Key) (list: 'T list) = + let countBy (projection: 'T -> 'Key) (list: 'T list) = match list with | [] -> [] | _ -> - if typeof<'Key>.IsValueType - then countByValueType projection list - else countByRefType projection list + if typeof<'Key>.IsValueType then + countByValueType projection list + else + countByRefType projection list [] - let map mapping list = Microsoft.FSharp.Primitives.Basics.List.map mapping list + let map mapping list = + Microsoft.FSharp.Primitives.Basics.List.map mapping list [] - let mapi mapping list = Microsoft.FSharp.Primitives.Basics.List.mapi mapping list + let mapi mapping list = + Microsoft.FSharp.Primitives.Basics.List.mapi mapping list [] - let indexed list = Microsoft.FSharp.Primitives.Basics.List.indexed list + let indexed list = + Microsoft.FSharp.Primitives.Basics.List.indexed list [] - let mapFold<'T, 'State, 'Result> (mapping:'State -> 'T -> 'Result * 'State) state list = + let mapFold<'T, 'State, 'Result> (mapping: 'State -> 'T -> 'Result * 'State) state list = Microsoft.FSharp.Primitives.Basics.List.mapFold mapping state list [] let mapFoldBack<'T, 'State, 'Result> (mapping: 'T -> 'State -> 'Result * 'State) list state = match list with | [] -> [], state - | [h] -> let h', s' = mapping h state in [h'], s' + | [ h ] -> let h', s' = mapping h state in [ h' ], s' | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (mapping) + let rec loop res list = match list, res with | [], _ -> res | h :: t, (list', acc') -> let h', s' = f.Invoke(h, acc') loop (h' :: list', s') t + loop ([], state) (rev list) [] - let inline iter ([] action) (list: 'T list) = for x in list do action x + let inline iter ([] action) (list: 'T list) = + for x in list do + action x [] - let distinct (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctWithComparer HashIdentity.Structural<'T> list + let distinct (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.distinctWithComparer HashIdentity.Structural<'T> list [] - let distinctBy projection (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctByWithComparer HashIdentity.Structural<_> projection list + let distinctBy projection (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.distinctByWithComparer HashIdentity.Structural<_> projection list [] - let ofArray (array: 'T array) = Microsoft.FSharp.Primitives.Basics.List.ofArray array + let ofArray (array: 'T array) = + Microsoft.FSharp.Primitives.Basics.List.ofArray array [] - let toArray (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.toArray list + let toArray (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.toArray list [] - let empty<'T> = ([ ] : 'T list) + let empty<'T> = ([]: 'T list) [] - let head list = match list with x :: _ -> x | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + let head list = + match list with + | x :: _ -> x + | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) [] - let tryHead list = match list with x :: _ -> Some x | [] -> None + let tryHead list = + match list with + | x :: _ -> Some x + | [] -> None [] - let tail list = match list with _ :: t -> t | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + let tail list = + match list with + | _ :: t -> t + | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) [] - let isEmpty list = match list with [] -> true | _ -> false + let isEmpty list = + match list with + | [] -> true + | _ -> false [] - let append list1 list2 = list1 @ list2 + let append list1 list2 = + list1 @ list2 [] let rec item index list = match list with | h :: t when index >= 0 -> - if index = 0 then h else item (index - 1) t - | _ -> - invalidArg "index" (SR.GetString(SR.indexOutOfBounds)) + if index = 0 then + h + else + item (index - 1) t + | _ -> invalidArg "index" (SR.GetString(SR.indexOutOfBounds)) [] let rec tryItem index list = match list with | h :: t when index >= 0 -> - if index = 0 then Some h else tryItem (index - 1) t - | _ -> - None + if index = 0 then + Some h + else + tryItem (index - 1) t + | _ -> None [] - let nth list index = item index list + let nth list index = + item index list [] - let choose chooser list = Microsoft.FSharp.Primitives.Basics.List.choose chooser list + let choose chooser list = + Microsoft.FSharp.Primitives.Basics.List.choose chooser list [] - let splitAt index (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.splitAt index list + let splitAt index (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.splitAt index list [] - let take count (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.take count list + let take count (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.take count list [] - let takeWhile predicate (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.takeWhile predicate list + let takeWhile predicate (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.takeWhile predicate list [] let inline iteri ([] action) (list: 'T list) = let mutable n = 0 - for x in list do action n x; n <- n + 1 + + for x in list do + action n x + n <- n + 1 [] - let init length initializer = Microsoft.FSharp.Primitives.Basics.List.init length initializer + let init length initializer = + Microsoft.FSharp.Primitives.Basics.List.init length initializer [] let replicate count initial = - if count < 0 then invalidArg "count" (SR.GetString(SR.inputMustBeNonNegative)) + if count < 0 then + invalidArg "count" (SR.GetString(SR.inputMustBeNonNegative)) + let mutable result = [] - for i in 0..count-1 do - result <- initial :: result + + for i in 0 .. count - 1 do + result <- initial :: result + result [] let iter2 action list1 list2 = - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (action) + let rec loop list1 list2 = match list1, list2 with | [], [] -> () - | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2); loop t1 t2 + | h1 :: t1, h2 :: t2 -> + f.Invoke(h1, h2) + loop t1 t2 | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + loop list1 list2 [] let iteri2 action list1 list2 = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(action) + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (action) + let rec loop n list1 list2 = match list1, list2 with | [], [] -> () - | h1 :: t1, h2 :: t2 -> f.Invoke(n, h1, h2); loop (n+1) t1 t2 + | h1 :: t1, h2 :: t2 -> + f.Invoke(n, h1, h2) + loop (n + 1) t1 t2 | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + loop 0 list1 list2 [] @@ -208,17 +279,20 @@ module List = Microsoft.FSharp.Primitives.Basics.List.mapi2 mapping list1 list2 [] - let map2 mapping list1 list2 = Microsoft.FSharp.Primitives.Basics.List.map2 mapping list1 list2 + let map2 mapping list1 list2 = + Microsoft.FSharp.Primitives.Basics.List.map2 mapping list1 list2 [] - let fold<'T, 'State> folder (state:'State) (list: 'T list) = + let fold<'T, 'State> folder (state: 'State) (list: 'T list) = match list with | [] -> state | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (folder) let mutable acc = state + for x in list do acc <- f.Invoke(acc, x) + acc [] @@ -232,39 +306,45 @@ module List = | h :: t -> fold reduction h t [] - let scan<'T, 'State> folder (state:'State) (list: 'T list) = + let scan<'T, 'State> folder (state: 'State) (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.scan folder state list [] - let inline singleton value = [value] + let inline singleton value = + [ value ] [] - let fold2<'T1, 'T2, 'State> folder (state:'State) (list1:'T1 list) (list2:'T2 list) = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) + let fold2<'T1, 'T2, 'State> folder (state: 'State) (list1: 'T1 list) (list2: 'T2 list) = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (folder) + let rec loop acc list1 list2 = match list1, list2 with | [], [] -> acc | h1 :: t1, h2 :: t2 -> loop (f.Invoke(acc, h1, h2)) t1 t2 | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + loop state list1 list2 - let foldArraySubRight (f:OptimizedClosures.FSharpFunc<'T, _, _>) (arr: 'T[]) start fin acc = + let foldArraySubRight (f: OptimizedClosures.FSharpFunc<'T, _, _>) (arr: 'T[]) start fin acc = let mutable state = acc + for i = fin downto start do state <- f.Invoke(arr.[i], state) + state // this version doesn't causes stack overflow - it uses a private stack [] - let foldBack<'T, 'State> folder (list: 'T list) (state:'State) = - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + let foldBack<'T, 'State> folder (list: 'T list) (state: 'State) = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (folder) + match list with | [] -> state - | [h] -> f.Invoke(h, state) - | [h1; h2] -> f.Invoke(h1, f.Invoke(h2, state)) - | [h1; h2; h3] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, state))) - | [h1; h2; h3; h4] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, f.Invoke(h4, state)))) + | [ h ] -> f.Invoke(h, state) + | [ h1; h2 ] -> f.Invoke(h1, f.Invoke(h2, state)) + | [ h1; h2; h3 ] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, state))) + | [ h1; h2; h3; h4 ] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, f.Invoke(h4, state)))) | _ -> // It is faster to allocate and iterate an array than to create all those // highly nested stacks. It also means we won't get stack overflows here. @@ -277,66 +357,80 @@ module List = match list with | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(reduction) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (reduction) let arr = toArray list let arrn = arr.Length foldArraySubRight f arr 0 (arrn - 2) arr.[arrn - 1] - let scanArraySubRight<'T, 'State> (f:OptimizedClosures.FSharpFunc<'T, 'State, 'State>) (arr: _[]) start fin initState = + let scanArraySubRight<'T, 'State> + (f: OptimizedClosures.FSharpFunc<'T, 'State, 'State>) + (arr: _[]) + start + fin + initState + = let mutable state = initState - let mutable res = [state] + let mutable res = [ state ] + for i = fin downto start do state <- f.Invoke(arr.[i], state) res <- state :: res + res [] - let scanBack<'T, 'State> folder (list: 'T list) (state:'State) = + let scanBack<'T, 'State> folder (list: 'T list) (state: 'State) = match list with - | [] -> [state] - | [h] -> - [folder h state; state] + | [] -> [ state ] + | [ h ] -> [ folder h state; state ] | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (folder) // It is faster to allocate and iterate an array than to create all those // highly nested stacks. It also means we won't get stack overflows here. let arr = toArray list let arrn = arr.Length scanArraySubRight f arr 0 (arrn - 1) state - let foldBack2UsingArrays (f:OptimizedClosures.FSharpFunc<_, _, _, _>) list1 list2 acc = + let foldBack2UsingArrays (f: OptimizedClosures.FSharpFunc<_, _, _, _>) list1 list2 acc = let arr1 = toArray list1 let arr2 = toArray list2 let n1 = arr1.Length let n2 = arr2.Length + if n1 <> n2 then - invalidArgFmt "list1, list2" + invalidArgFmt + "list1, list2" "{0}\nlist1.Length = {1}, list2.Length = {2}" - [|SR.GetString SR.listsHadDifferentLengths; arr1.Length; arr2.Length|] + [| SR.GetString SR.listsHadDifferentLengths; arr1.Length; arr2.Length |] + let mutable res = acc + for i = n1 - 1 downto 0 do res <- f.Invoke(arr1.[i], arr2.[i], res) + res [] - let rec foldBack2<'T1, 'T2, 'State> folder (list1:'T1 list) (list2:'T2 list) (state:'State) = + let rec foldBack2<'T1, 'T2, 'State> folder (list1: 'T1 list) (list2: 'T2 list) (state: 'State) = match list1, list2 with | [], [] -> state | h1 :: rest1, k1 :: rest2 -> - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (folder) + match rest1, rest2 with | [], [] -> f.Invoke(h1, k1, state) - | [h2], [k2] -> f.Invoke(h1, k1, f.Invoke(h2, k2, state)) - | [h2; h3], [k2; k3] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, state))) - | [h2; h3; h4], [k2; k3; k4] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, f.Invoke(h4, k4, state)))) + | [ h2 ], [ k2 ] -> f.Invoke(h1, k1, f.Invoke(h2, k2, state)) + | [ h2; h3 ], [ k2; k3 ] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, state))) + | [ h2; h3; h4 ], [ k2; k3; k4 ] -> + f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, f.Invoke(h4, k4, state)))) | _ -> foldBack2UsingArrays f list1 list2 state | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - let rec forall2aux (f:OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = + let rec forall2aux (f: OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = match list1, list2 with | [], [] -> true - | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2) && forall2aux f t1 t2 + | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2) && forall2aux f t1 t2 | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length @@ -345,14 +439,16 @@ module List = match list1, list2 with | [], [] -> true | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (predicate) forall2aux f list1 list2 [] - let forall predicate list = Microsoft.FSharp.Primitives.Basics.List.forall predicate list + let forall predicate list = + Microsoft.FSharp.Primitives.Basics.List.forall predicate list [] - let exists predicate list = Microsoft.FSharp.Primitives.Basics.List.exists predicate list + let exists predicate list = + Microsoft.FSharp.Primitives.Basics.List.exists predicate list [] let inline contains value source = @@ -360,12 +456,13 @@ module List = match xs1 with | [] -> false | h1 :: t1 -> e = h1 || contains e t1 + contains value source - let rec exists2aux (f:OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = + let rec exists2aux (f: OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = match list1, list2 with | [], [] -> false - | h1 :: t1, h2 :: t2 ->f.Invoke(h1, h2) || exists2aux f t1 t2 + | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2) || exists2aux f t1 t2 | _ -> invalidArg "list2" (SR.GetString(SR.listsHadDifferentLengths)) [] @@ -373,26 +470,38 @@ module List = match list1, list2 with | [], [] -> false | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (predicate) exists2aux f list1 list2 [] - let rec find predicate list = + let rec find predicate list = match list with - | [] -> indexNotFound() - | h :: t -> if predicate h then h else find predicate t + | [] -> indexNotFound () + | h :: t -> + if predicate h then + h + else + find predicate t [] let rec tryFind predicate list = match list with - | [] -> None - | h :: t -> if predicate h then Some h else tryFind predicate t + | [] -> None + | h :: t -> + if predicate h then + Some h + else + tryFind predicate t [] - let findBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.findBack predicate + let findBack predicate list = + list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.findBack predicate [] - let tryFindBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.tryFindBack predicate + let tryFindBack predicate list = + list + |> toArray + |> Microsoft.FSharp.Primitives.Basics.Array.tryFindBack predicate [] let rec tryPick chooser list = @@ -406,18 +515,20 @@ module List = [] let rec pick chooser list = match list with - | [] -> indexNotFound() + | [] -> indexNotFound () | h :: t -> match chooser h with | None -> pick chooser t | Some r -> r [] - let filter predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate list + let filter predicate list = + Microsoft.FSharp.Primitives.Basics.List.filter predicate list [] let except (itemsToExclude: seq<'T>) list = checkNonNull "itemsToExclude" itemsToExclude + match list with | [] -> list | _ -> @@ -425,59 +536,83 @@ module List = list |> filter cached.Add [] - let where predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate list - - let inline groupByImpl (comparer:IEqualityComparer<'SafeKey>) (keyf: 'T->'SafeKey) (getKey:'SafeKey->'Key) (list: 'T list) = + let where predicate list = + Microsoft.FSharp.Primitives.Basics.List.filter predicate list + + let inline groupByImpl + (comparer: IEqualityComparer<'SafeKey>) + (keyf: 'T -> 'SafeKey) + (getKey: 'SafeKey -> 'Key) + (list: 'T list) + = Microsoft.FSharp.Primitives.Basics.List.groupBy comparer keyf getKey list // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let groupByValueType (keyf: 'T->'Key) (list: 'T list) = groupByImpl HashIdentity.Structural<'Key> keyf id list + let groupByValueType (keyf: 'T -> 'Key) (list: 'T list) = + groupByImpl HashIdentity.Structural<'Key> keyf id list // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let groupByRefType (keyf: 'T->'Key) (list: 'T list) = groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) list + let groupByRefType (keyf: 'T -> 'Key) (list: 'T list) = + groupByImpl + RuntimeHelpers.StructBox<'Key>.Comparer + (fun t -> RuntimeHelpers.StructBox(keyf t)) + (fun sb -> sb.Value) + list [] - let groupBy (projection: 'T->'Key) (list: 'T list) = + let groupBy (projection: 'T -> 'Key) (list: 'T list) = match list with | [] -> [] | _ -> - if typeof<'Key>.IsValueType - then groupByValueType projection list - else groupByRefType projection list + if typeof<'Key>.IsValueType then + groupByValueType projection list + else + groupByRefType projection list [] - let partition predicate list = Microsoft.FSharp.Primitives.Basics.List.partition predicate list + let partition predicate list = + Microsoft.FSharp.Primitives.Basics.List.partition predicate list [] - let unzip list = Microsoft.FSharp.Primitives.Basics.List.unzip list + let unzip list = + Microsoft.FSharp.Primitives.Basics.List.unzip list [] - let unzip3 list = Microsoft.FSharp.Primitives.Basics.List.unzip3 list + let unzip3 list = + Microsoft.FSharp.Primitives.Basics.List.unzip3 list [] - let windowed windowSize list = Microsoft.FSharp.Primitives.Basics.List.windowed windowSize list + let windowed windowSize list = + Microsoft.FSharp.Primitives.Basics.List.windowed windowSize list [] - let chunkBySize chunkSize list = Microsoft.FSharp.Primitives.Basics.List.chunkBySize chunkSize list + let chunkBySize chunkSize list = + Microsoft.FSharp.Primitives.Basics.List.chunkBySize chunkSize list [] - let splitInto count list = Microsoft.FSharp.Primitives.Basics.List.splitInto count list + let splitInto count list = + Microsoft.FSharp.Primitives.Basics.List.splitInto count list [] - let zip list1 list2 = Microsoft.FSharp.Primitives.Basics.List.zip list1 list2 + let zip list1 list2 = + Microsoft.FSharp.Primitives.Basics.List.zip list1 list2 [] - let zip3 list1 list2 list3 = Microsoft.FSharp.Primitives.Basics.List.zip3 list1 list2 list3 + let zip3 list1 list2 list3 = + Microsoft.FSharp.Primitives.Basics.List.zip3 list1 list2 list3 [] let skip count list = - if count <= 0 then list else - let rec loop i lst = - match lst with - | _ when i = 0 -> lst - | _ :: t -> loop (i-1) t - | [] -> invalidArgOutOfRange "count" count "distance past the list" i - loop count list + if count <= 0 then + list + else + let rec loop i lst = + match lst with + | _ when i = 0 -> lst + | _ :: t -> loop (i - 1) t + | [] -> invalidArgOutOfRange "count" count "distance past the list" i + + loop count list [] let rec skipWhile predicate list = @@ -488,7 +623,8 @@ module List = [] let sortWith comparer list = match list with - | [] | [_] -> list + | [] + | [ _ ] -> list | _ -> let array = Microsoft.FSharp.Primitives.Basics.List.toArray list Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceWith comparer array @@ -497,7 +633,8 @@ module List = [] let sortBy projection list = match list with - | [] | [_] -> list + | [] + | [ _ ] -> list | _ -> let array = Microsoft.FSharp.Primitives.Basics.List.toArray list Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceBy projection array @@ -506,7 +643,8 @@ module List = [] let sort list = match list with - | [] | [_] -> list + | [] + | [ _ ] -> list | _ -> let array = Microsoft.FSharp.Primitives.Basics.List.toArray list Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlace array @@ -514,35 +652,49 @@ module List = [] let inline sortByDescending projection list = - let inline compareDescending a b = compare (projection b) (projection a) + let inline compareDescending a b = + compare (projection b) (projection a) + sortWith compareDescending list [] let inline sortDescending list = - let inline compareDescending a b = compare b a + let inline compareDescending a b = + compare b a + sortWith compareDescending list [] - let ofSeq source = Seq.toList source + let ofSeq source = + Seq.toList source [] - let toSeq list = Seq.ofList list + let toSeq list = + Seq.ofList list [] let findIndex predicate list = - let rec loop n list = - match list with - | [] -> indexNotFound() - | h :: t -> if predicate h then n else loop (n + 1) t + let rec loop n list = + match list with + | [] -> indexNotFound () + | h :: t -> + if predicate h then + n + else + loop (n + 1) t loop 0 list [] let tryFindIndex predicate list = - let rec loop n list = + let rec loop n list = match list with | [] -> None - | h :: t -> if predicate h then Some n else loop (n + 1) t + | h :: t -> + if predicate h then + Some n + else + loop (n + 1) t loop 0 list @@ -564,8 +716,10 @@ module List = | [] -> LanguagePrimitives.GenericZero<'T> | t -> let mutable acc = LanguagePrimitives.GenericZero<'T> + for x in t do acc <- Checked.(+) acc x + acc [] @@ -574,8 +728,10 @@ module List = | [] -> LanguagePrimitives.GenericZero<'U> | t -> let mutable acc = LanguagePrimitives.GenericZero<'U> + for x in t do acc <- Checked.(+) acc (projection x) + acc [] @@ -584,9 +740,10 @@ module List = | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString | h :: t -> let mutable acc = h + for x in t do - if x > acc then - acc <- x + if x > acc then acc <- x + acc [] @@ -596,11 +753,14 @@ module List = | h :: t -> let mutable acc = h let mutable accv = projection h + for x in t do let currv = projection x + if currv > accv then acc <- x accv <- currv + acc [] @@ -609,9 +769,10 @@ module List = | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString | h :: t -> let mutable acc = h + for x in t do - if x < acc then - acc <- x + if x < acc then acc <- x + acc [] @@ -621,11 +782,14 @@ module List = | h :: t -> let mutable acc = h let mutable accv = projection h + for x in t do let currv = projection x + if currv < accv then acc <- x accv <- currv + acc [] @@ -635,9 +799,11 @@ module List = | xs -> let mutable sum = LanguagePrimitives.GenericZero<'T> let mutable count = 0 + for x in xs do sum <- Checked.(+) sum x count <- count + 1 + LanguagePrimitives.DivideByInt sum count [] @@ -647,45 +813,53 @@ module List = | xs -> let mutable sum = LanguagePrimitives.GenericZero<'U> let mutable count = 0 + for x in xs do sum <- Checked.(+) sum (projection x) count <- count + 1 + LanguagePrimitives.DivideByInt sum count [] - let collect mapping list = Microsoft.FSharp.Primitives.Basics.List.collect mapping list + let collect mapping list = + Microsoft.FSharp.Primitives.Basics.List.collect mapping list [] - let allPairs list1 list2 = Microsoft.FSharp.Primitives.Basics.List.allPairs list1 list2 + let allPairs list1 list2 = + Microsoft.FSharp.Primitives.Basics.List.allPairs list1 list2 [] let inline compareWith ([] comparer: 'T -> 'T -> int) (list1: 'T list) (list2: 'T list) = let rec loop list1 list2 = - match list1, list2 with - | head1 :: tail1, head2 :: tail2 -> - let c = comparer head1 head2 - if c = 0 then loop tail1 tail2 else c - | [], [] -> 0 - | _, [] -> 1 - | [], _ -> -1 + match list1, list2 with + | head1 :: tail1, head2 :: tail2 -> + let c = comparer head1 head2 + if c = 0 then loop tail1 tail2 else c + | [], [] -> 0 + | _, [] -> 1 + | [], _ -> -1 loop list1 list2 [] - let permute indexMap list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.permute indexMap |> ofArray + let permute indexMap list = + list + |> toArray + |> Microsoft.FSharp.Primitives.Basics.Array.permute indexMap + |> ofArray [] let exactlyOne (list: _ list) = match list with - | [x] -> x - | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | _ -> invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) + | [ x ] -> x + | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | _ -> invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) [] let tryExactlyOne (list: _ list) = match list with - | [x] -> Some x - | _ -> None + | [ x ] -> Some x + | _ -> None [] let transpose (lists: seq<'T list>) = @@ -693,93 +867,119 @@ module List = Microsoft.FSharp.Primitives.Basics.List.transpose (ofSeq lists) [] - let truncate count list = Microsoft.FSharp.Primitives.Basics.List.truncate count list + let truncate count list = + Microsoft.FSharp.Primitives.Basics.List.truncate count list [] - let unfold<'T, 'State> (generator:'State -> ('T*'State) option) (state:'State) = Microsoft.FSharp.Primitives.Basics.List.unfold generator state + let unfold<'T, 'State> (generator: 'State -> ('T * 'State) option) (state: 'State) = + Microsoft.FSharp.Primitives.Basics.List.unfold generator state [] let removeAt (index: int) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" + if index < 0 then + invalidArg "index" "index must be within bounds of the list" let mutable i = 0 let mutable coll = ListCollector() let mutable curr = source + while i < index do // traverse and save the linked list until item to be removed - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 - if curr.IsEmpty then invalidArg "index" "index must be within bounds of the list" - else coll.AddManyAndClose(curr.Tail) // when i = index, Head is the item which is ignored and Tail is the rest of the list + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h :: t -> + coll.Add(h) + curr <- t + + i <- i + 1 + + if curr.IsEmpty then + invalidArg "index" "index must be within bounds of the list" + else + coll.AddManyAndClose(curr.Tail) // when i = index, Head is the item which is ignored and Tail is the rest of the list [] let removeManyAt (index: int) (count: int) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" + if index < 0 then + invalidArg "index" "index must be within bounds of the list" let mutable i = 0 let mutable coll = ListCollector() let mutable curr = source + while i < index + count do // traverse and save the linked list until the last item to be removed - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - if i < index then coll.Add(h) //items before index we keep - curr <- t - i <- i + 1 + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h :: t -> + if i < index then coll.Add(h) //items before index we keep + curr <- t + + i <- i + 1 + coll.AddManyAndClose(curr) // when i = index + count, we keep the rest of the list [] let updateAt (index: int) (value: 'T) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" + if index < 0 then + invalidArg "index" "index must be within bounds of the list" let mutable i = 0 let mutable coll = ListCollector() let mutable curr = source + while i < index do // Traverse and save the linked list until index - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h :: t -> + coll.Add(h) + curr <- t + + i <- i + 1 + coll.Add(value) // add value instead of Head - if curr.IsEmpty then invalidArg "index" "index must be within bounds of the list" - else coll.AddManyAndClose(curr.Tail) + + if curr.IsEmpty then + invalidArg "index" "index must be within bounds of the list" + else + coll.AddManyAndClose(curr.Tail) [] let insertAt (index: int) (value: 'T) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" + if index < 0 then + invalidArg "index" "index must be within bounds of the list" let mutable i = 0 let mutable coll = ListCollector() let mutable curr = source + while i < index do // traverse and save the linked list until index - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 - + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h :: t -> + coll.Add(h) + curr <- t + + i <- i + 1 + coll.Add(value) coll.AddManyAndClose(curr) // insert item BEFORE the item at the index [] let insertManyAt (index: int) (values: seq<'T>) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" + if index < 0 then + invalidArg "index" "index must be within bounds of the list" let mutable i = 0 let mutable coll = ListCollector() let mutable curr = source + while i < index do // traverse and save the linked list until index - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h :: t -> + coll.Add(h) + curr <- t + + i <- i + 1 + coll.AddMany(values) // insert values BEFORE the item at the index - coll.AddManyAndClose(curr) \ No newline at end of file + coll.AddManyAndClose(curr) diff --git a/src/FSharp.Core/local.fsi b/src/FSharp.Core/local.fsi index ddf14b9c2bc..e4d26e76e2b 100644 --- a/src/FSharp.Core/local.fsi +++ b/src/FSharp.Core/local.fsi @@ -43,8 +43,9 @@ module internal List = val distinctWithComparer: System.Collections.Generic.IEqualityComparer<'T> -> 'T list -> 'T list - val distinctByWithComparer: System.Collections.Generic.IEqualityComparer<'Key> -> ('T -> 'Key) -> list: 'T list -> 'T list - when 'Key: equality + val distinctByWithComparer: + System.Collections.Generic.IEqualityComparer<'Key> -> ('T -> 'Key) -> list: 'T list -> 'T list + when 'Key: equality val init: int -> (int -> 'T) -> 'T list val filter: predicate: ('T -> bool) -> 'T list -> 'T list diff --git a/src/FSharp.Core/mailbox.fs b/src/FSharp.Core/mailbox.fs index 78035f34727..91c60d25cb3 100644 --- a/src/FSharp.Core/mailbox.fs +++ b/src/FSharp.Core/mailbox.fs @@ -18,13 +18,22 @@ module AsyncHelpers = async { let resultCell = new ResultCell<_>() let! cancellationToken = Async.CancellationToken + let start a f = - Async.StartWithContinuationsUsingDispatchInfo(a, - (fun res -> resultCell.RegisterResult(f res |> AsyncResult.Ok, reuseThread=false) |> ignore), - (fun edi -> resultCell.RegisterResult(edi |> AsyncResult.Error, reuseThread=false) |> ignore), - (fun oce -> resultCell.RegisterResult(oce |> AsyncResult.Canceled, reuseThread=false) |> ignore), + Async.StartWithContinuationsUsingDispatchInfo( + a, + (fun res -> + resultCell.RegisterResult(f res |> AsyncResult.Ok, reuseThread = false) + |> ignore), + (fun edi -> + resultCell.RegisterResult(edi |> AsyncResult.Error, reuseThread = false) + |> ignore), + (fun oce -> + resultCell.RegisterResult(oce |> AsyncResult.Canceled, reuseThread = false) + |> ignore), cancellationToken = cancellationToken - ) + ) + start a1 Choice1Of2 start a2 Choice2Of2 // Note: It is ok to use "NoDirectCancel" here because the started computations use the same @@ -37,12 +46,14 @@ module AsyncHelpers = let timeout msec cancellationToken = assert (msec >= 0) let resultCell = new ResultCell<_>() + Async.StartWithContinuations( - computation=Async.Sleep msec, - continuation=(fun () -> resultCell.RegisterResult((), reuseThread = false) |> ignore), - exceptionContinuation=ignore, - cancellationContinuation=ignore, - cancellationToken = cancellationToken) + computation = Async.Sleep msec, + continuation = (fun () -> resultCell.RegisterResult((), reuseThread = false) |> ignore), + exceptionContinuation = ignore, + cancellationContinuation = ignore, + cancellationToken = cancellationToken + ) // Note: It is ok to use "NoDirectCancel" here because the started computations use the same // cancellation token and will register a cancelled result if cancellation occurs. // Note: It is ok to use "NoDirectTimeout" here because the child compuation above looks after the timeout. @@ -51,7 +62,7 @@ module AsyncHelpers = [] [] type Mailbox<'Msg>(cancellationSupported: bool) = - let mutable inboxStore = null + let mutable inboxStore = null let arrivals = Queue<'Msg>() let syncRoot = arrivals @@ -59,22 +70,21 @@ type Mailbox<'Msg>(cancellationSupported: bool) = // asynchronous receive, either // -- "cont" is non-null and the reader is "activated" by re-scheduling cont in the thread pool; or // -- "pulse" is non-null and the reader is "activated" by setting this event - let mutable savedCont : (bool -> AsyncReturn) option = None + let mutable savedCont: (bool -> AsyncReturn) option = None // Readers who have a timeout use this event - let mutable pulse : AutoResetEvent = null + let mutable pulse: AutoResetEvent = null // Make sure that the "pulse" value is created - let ensurePulse() = + let ensurePulse () = match pulse with - | null -> - pulse <- new AutoResetEvent(false) - | _ -> - () + | null -> pulse <- new AutoResetEvent(false) + | _ -> () + pulse let waitOneNoTimeoutOrCancellation = - MakeAsync (fun ctxt -> + MakeAsync(fun ctxt -> match savedCont with | None -> let descheduled = @@ -86,16 +96,16 @@ type Mailbox<'Msg>(cancellationSupported: bool) = true else false) + if descheduled then Unchecked.defaultof<_> else // If we didn't deschedule then run the continuation immediately ctxt.CallContinuation true - | Some _ -> - failwith "multiple waiting reader continuations for mailbox") + | Some _ -> failwith "multiple waiting reader continuations for mailbox") let waitOneWithCancellation timeout = - Async.AwaitWaitHandle(ensurePulse(), millisecondsTimeout=timeout) + Async.AwaitWaitHandle(ensurePulse (), millisecondsTimeout = timeout) let waitOne timeout = if timeout < 0 && not cancellationSupported then @@ -107,16 +117,17 @@ type Mailbox<'Msg>(cancellationSupported: bool) = match inboxStore with | null -> inboxStore <- new System.Collections.Generic.List<'Msg>(1) | _ -> () + inboxStore - member x.CurrentQueueLength = - lock syncRoot (fun () -> x.inbox.Count + arrivals.Count) + member x.CurrentQueueLength = lock syncRoot (fun () -> x.inbox.Count + arrivals.Count) member x.ScanArrivalsUnsafe f = if arrivals.Count = 0 then None else let msg = arrivals.Dequeue() + match f msg with | None -> x.inbox.Add msg @@ -131,13 +142,16 @@ type Mailbox<'Msg>(cancellationSupported: bool) = match inboxStore with | null -> None | inbox -> - if n >= inbox.Count - then None + if n >= inbox.Count then + None else let msg = inbox.[n] + match f msg with - | None -> x.ScanInbox (f, n+1) - | res -> inbox.RemoveAt n; res + | None -> x.ScanInbox(f, n + 1) + | res -> + inbox.RemoveAt n + res member x.ReceiveFromArrivalsUnsafe() = if arrivals.Count = 0 then @@ -170,8 +184,7 @@ type Mailbox<'Msg>(cancellationSupported: bool) = match savedCont with | None -> match pulse with - | null -> - () // no one waiting, leaving the message in the queue is sufficient + | null -> () // no one waiting, leaving the message in the queue is sufficient | ev -> // someone is waiting on the wait handle ev.Set() |> ignore @@ -180,16 +193,16 @@ type Mailbox<'Msg>(cancellationSupported: bool) = savedCont <- None action true |> ignore) - member x.TryScan ((f: 'Msg -> (Async<'T>) option), timeout) : Async<'T option> = - let rec scan timeoutAsync (timeoutCts:CancellationTokenSource) = + member x.TryScan((f: 'Msg -> (Async<'T>) option), timeout) : Async<'T option> = + let rec scan timeoutAsync (timeoutCts: CancellationTokenSource) = async { match x.ScanArrivals f with | None -> // Deschedule and wait for a message. When it comes, rescan the arrivals let! ok = AsyncHelpers.awaitEither waitOneNoTimeoutOrCancellation timeoutAsync + match ok with - | Choice1Of2 true -> - return! scan timeoutAsync timeoutCts + | Choice1Of2 true -> return! scan timeoutAsync timeoutCts | Choice1Of2 false -> return failwith "should not happen - waitOneNoTimeoutOrCancellation always returns true" | Choice2Of2 () -> @@ -214,13 +227,15 @@ type Mailbox<'Msg>(cancellationSupported: bool) = let! res = resP return Some res } + let rec scanNoTimeout () = async { match x.ScanArrivals f with | None -> let! ok = waitOne Timeout.Infinite + if ok then - return! scanNoTimeout() + return! scanNoTimeout () else return (failwith "Timed out with infinite timeout??") | Some resP -> @@ -231,11 +246,13 @@ type Mailbox<'Msg>(cancellationSupported: bool) = // Look in the inbox first async { match x.ScanInbox(f, 0) with - | None when timeout < 0 -> - return! scanNoTimeout() + | None when timeout < 0 -> return! scanNoTimeout () | None -> let! cancellationToken = Async.CancellationToken - let timeoutCts = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, CancellationToken.None) + + let timeoutCts = + CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, CancellationToken.None) + let timeoutAsync = AsyncHelpers.timeout timeout timeoutCts.Token return! scan timeoutAsync timeoutCts | Some resP -> @@ -246,13 +263,14 @@ type Mailbox<'Msg>(cancellationSupported: bool) = member x.Scan((f: 'Msg -> (Async<'T>) option), timeout) = async { let! resOpt = x.TryScan(f, timeout) + match resOpt with - | None -> return raise(TimeoutException(SR.GetString(SR.mailboxScanTimedOut))) + | None -> return raise (TimeoutException(SR.GetString(SR.mailboxScanTimedOut))) | Some res -> return res } member x.TryReceive timeout = - let rec processFirstArrival() = + let rec processFirstArrival () = async { match x.ReceiveFromArrivals() with | None -> @@ -261,13 +279,14 @@ type Mailbox<'Msg>(cancellationSupported: bool) = // check arrivals again. match pulse with | null when timeout >= 0 || cancellationSupported -> - ensurePulse() |> ignore - return! processFirstArrival() + ensurePulse () |> ignore + return! processFirstArrival () | _ -> // Wait until we have been notified about a message. When that happens, rescan the arrivals let! ok = waitOne timeout + if ok then - return! processFirstArrival() + return! processFirstArrival () else return None | res -> return res @@ -276,13 +295,13 @@ type Mailbox<'Msg>(cancellationSupported: bool) = // look in the inbox first async { match x.ReceiveFromInbox() with - | None -> return! processFirstArrival() + | None -> return! processFirstArrival () | res -> return res } member x.Receive timeout = - let rec processFirstArrival() = + let rec processFirstArrival () = async { match x.ReceiveFromArrivals() with | None -> @@ -291,39 +310,40 @@ type Mailbox<'Msg>(cancellationSupported: bool) = // check arrivals again. match pulse with | null when timeout >= 0 || cancellationSupported -> - ensurePulse() |> ignore - return! processFirstArrival() + ensurePulse () |> ignore + return! processFirstArrival () | _ -> // Wait until we have been notified about a message. When that happens, rescan the arrivals let! ok = waitOne timeout + if ok then - return! processFirstArrival() + return! processFirstArrival () else - return raise(TimeoutException(SR.GetString(SR.mailboxReceiveTimedOut))) + return raise (TimeoutException(SR.GetString(SR.mailboxReceiveTimedOut))) | Some res -> return res } // look in the inbox first async { match x.ReceiveFromInbox() with - | None -> return! processFirstArrival() + | None -> return! processFirstArrival () | Some res -> return res } interface System.IDisposable with member _.Dispose() = - if isNotNull pulse then (pulse :> IDisposable).Dispose() + if isNotNull pulse then + (pulse :> IDisposable).Dispose() #if DEBUG - member x.UnsafeContents = - (x.inbox, arrivals, pulse, savedCont) |> box + member x.UnsafeContents = (x.inbox, arrivals, pulse, savedCont) |> box #endif - [] [] -type AsyncReplyChannel<'Reply>(replyf : 'Reply -> unit) = - member x.Reply value = replyf value +type AsyncReplyChannel<'Reply>(replyf: 'Reply -> unit) = + member x.Reply value = + replyf value [] [] @@ -340,7 +360,7 @@ type MailboxProcessor<'Msg>(body, ?cancellationToken) = member _.CurrentQueueLength = mailbox.CurrentQueueLength // nb. unprotected access gives an approximation of the queue length member _.DefaultTimeout - with get() = defaultTimeout + with get () = defaultTimeout and set v = defaultTimeout <- v [] @@ -360,81 +380,118 @@ type MailboxProcessor<'Msg>(body, ?cancellationToken) = // Note that exception stack traces are lost in this design - in an extended design // the event could propagate an ExceptionDispatchInfo instead of an Exception. let p = - async { try - do! body x - with exn -> - errorEvent.Trigger exn } + async { + try + do! body x + with exn -> + errorEvent.Trigger exn + } - Async.Start(computation=p, cancellationToken=cancellationToken) + Async.Start(computation = p, cancellationToken = cancellationToken) - member _.Post message = mailbox.Post message + member _.Post message = + mailbox.Post message - member _.TryPostAndReply(buildMessage : (_ -> 'Msg), ?timeout) : 'Reply option = + member _.TryPostAndReply(buildMessage: (_ -> 'Msg), ?timeout) : 'Reply option = let timeout = defaultArg timeout defaultTimeout use resultCell = new ResultCell<_>() - let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> - // Note the ResultCell may have been disposed if the operation - // timed out. In this case RegisterResult drops the result on the floor. - resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) + + let msg = + buildMessage ( + new AsyncReplyChannel<_>(fun reply -> + // Note the ResultCell may have been disposed if the operation + // timed out. In this case RegisterResult drops the result on the floor. + resultCell.RegisterResult(reply, reuseThread = false) |> ignore) + ) + mailbox.Post msg - resultCell.TryWaitForResultSynchronously(timeout=timeout) + resultCell.TryWaitForResultSynchronously(timeout = timeout) member x.PostAndReply(buildMessage, ?timeout) : 'Reply = - match x.TryPostAndReply(buildMessage, ?timeout=timeout) with - | None -> raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndReplyTimedOut))) + match x.TryPostAndReply(buildMessage, ?timeout = timeout) with + | None -> raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndReplyTimedOut))) | Some res -> res member _.PostAndTryAsyncReply(buildMessage, ?timeout) : Async<'Reply option> = let timeout = defaultArg timeout defaultTimeout let resultCell = new ResultCell<_>() - let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> - // Note the ResultCell may have been disposed if the operation - // timed out. In this case RegisterResult drops the result on the floor. - resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) + + let msg = + buildMessage ( + new AsyncReplyChannel<_>(fun reply -> + // Note the ResultCell may have been disposed if the operation + // timed out. In this case RegisterResult drops the result on the floor. + resultCell.RegisterResult(reply, reuseThread = false) |> ignore) + ) + mailbox.Post msg + match timeout with | Threading.Timeout.Infinite when not cancellationSupported -> - async { let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout - return Some result } + async { + let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout + return Some result + } | _ -> - async { use _disposeCell = resultCell - let! ok = Async.AwaitWaitHandle(resultCell.GetWaitHandle(), millisecondsTimeout=timeout) - let res = (if ok then Some(resultCell.GrabResult()) else None) - return res } + async { + use _disposeCell = resultCell + let! ok = Async.AwaitWaitHandle(resultCell.GetWaitHandle(), millisecondsTimeout = timeout) + + let res = + (if ok then + Some(resultCell.GrabResult()) + else + None) - member x.PostAndAsyncReply(buildMessage, ?timeout:int) = + return res + } + + member x.PostAndAsyncReply(buildMessage, ?timeout: int) = let timeout = defaultArg timeout defaultTimeout + match timeout with | Threading.Timeout.Infinite when not cancellationSupported -> // Nothing to dispose, no wait handles used let resultCell = new ResultCell<_>() - let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) + + let channel = + AsyncReplyChannel<_>(fun reply -> resultCell.RegisterResult(reply, reuseThread = false) |> ignore) + + let msg = buildMessage channel + mailbox.Post msg resultCell.AwaitResult_NoDirectCancelOrTimeout | _ -> - let asyncReply = x.PostAndTryAsyncReply(buildMessage, timeout=timeout) - async { let! res = asyncReply - match res with - | None -> return! raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndAsyncReplyTimedOut))) - | Some res -> return res } + let asyncReply = x.PostAndTryAsyncReply(buildMessage, timeout = timeout) + + async { + let! res = asyncReply + + match res with + | None -> return! raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndAsyncReplyTimedOut))) + | Some res -> return res + } member _.Receive(?timeout) = - mailbox.Receive(timeout=defaultArg timeout defaultTimeout) + mailbox.Receive(timeout = defaultArg timeout defaultTimeout) member _.TryReceive(?timeout) = - mailbox.TryReceive(timeout=defaultArg timeout defaultTimeout) + mailbox.TryReceive(timeout = defaultArg timeout defaultTimeout) member _.Scan(scanner: 'Msg -> (Async<'T>) option, ?timeout) = - mailbox.Scan(scanner, timeout=defaultArg timeout defaultTimeout) + mailbox.Scan(scanner, timeout = defaultArg timeout defaultTimeout) member _.TryScan(scanner: 'Msg -> (Async<'T>) option, ?timeout) = - mailbox.TryScan(scanner, timeout=defaultArg timeout defaultTimeout) + mailbox.TryScan(scanner, timeout = defaultArg timeout defaultTimeout) interface System.IDisposable with - member _.Dispose() = (mailbox :> IDisposable).Dispose() + member _.Dispose() = + (mailbox :> IDisposable).Dispose() static member Start(body, ?cancellationToken) = - let mailboxProcessor = new MailboxProcessor<'Msg>(body, ?cancellationToken=cancellationToken) + let mailboxProcessor = + new MailboxProcessor<'Msg>(body, ?cancellationToken = cancellationToken) + mailboxProcessor.Start() mailboxProcessor diff --git a/src/FSharp.Core/map.fs b/src/FSharp.Core/map.fs index 7a72f29b1d8..0d510239f32 100644 --- a/src/FSharp.Core/map.fs +++ b/src/FSharp.Core/map.fs @@ -17,38 +17,45 @@ type internal MapTree<'Key, 'Value>(k: 'Key, v: 'Value, h: int) = member _.Height = h member _.Key = k member _.Value = v - new(k: 'Key, v: 'Value) = MapTree(k,v,1) - + new(k: 'Key, v: 'Value) = MapTree(k, v, 1) + [] [] [] -type internal MapTreeNode<'Key, 'Value>(k:'Key, v:'Value, left:MapTree<'Key, 'Value>, right: MapTree<'Key, 'Value>, h: int) = - inherit MapTree<'Key,'Value>(k, v, h) +type internal MapTreeNode<'Key, 'Value> + ( + k: 'Key, + v: 'Value, + left: MapTree<'Key, 'Value>, + right: MapTree<'Key, 'Value>, + h: int + ) = + inherit MapTree<'Key, 'Value>(k, v, h) member _.Left = left member _.Right = right - - + [] -module MapTree = - +module MapTree = + let empty = null - - let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m - - let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = - value :?> MapTreeNode<'Key,'Value> - - let rec sizeAux acc (m:MapTree<'Key, 'Value>) = + + let inline isEmpty (m: MapTree<'Key, 'Value>) = + isNull m + + let inline private asNode (value: MapTree<'Key, 'Value>) : MapTreeNode<'Key, 'Value> = + value :?> MapTreeNode<'Key, 'Value> + + let rec sizeAux acc (m: MapTree<'Key, 'Value>) = if isEmpty m then acc + else if m.Height = 1 then + acc + 1 else - if m.Height = 1 then - acc + 1 - else - let mn = asNode m - sizeAux (sizeAux (acc+1) mn.Left) mn.Right - - let size x = sizeAux 0 x + let mn = asNode m + sizeAux (sizeAux (acc + 1) mn.Left) mn.Right + + let size x = + sizeAux 0 x #if TRACE_SETS_AND_MAPS let mutable traceCount = 0 @@ -64,373 +71,462 @@ module MapTree = let mutable largestMapSize = 0 let mutable largestMapStackTrace = Unchecked.defaultof<_> - let report() = - traceCount <- traceCount + 1 - if traceCount % 1000000 = 0 then - System.Console.WriteLine( - "#MapOne = {0}, #MapNode = {1}, #Add = {2}, #Remove = {3}, #Unions = {4}, #Lookups = {5}, avMapTreeSizeOnNodeCreation = {6}, avMapSizeOnCreation = {7}, avMapSizeOnLookup = {8}", - numOnes, numNodes, numAdds, numRemoves, numUnions, numLookups, - (totalSizeOnNodeCreation / float (numNodes + numOnes)), (totalSizeOnMapAdd / float numAdds), - (totalSizeOnMapLookup / float numLookups)) - System.Console.WriteLine("#largestMapSize = {0}, largestMapStackTrace = {1}", largestMapSize, largestMapStackTrace) - - let MapTree (k,v) = - report() + let report () = + traceCount <- traceCount + 1 + + if traceCount % 1000000 = 0 then + Console.WriteLine( + "#MapOne = {0}, #MapNode = {1}, #Add = {2}, #Remove = {3}, #Unions = {4}, #Lookups = {5}, avMapTreeSizeOnNodeCreation = {6}, avMapSizeOnCreation = {7}, avMapSizeOnLookup = {8}", + numOnes, + numNodes, + numAdds, + numRemoves, + numUnions, + numLookups, + (totalSizeOnNodeCreation / float (numNodes + numOnes)), + (totalSizeOnMapAdd / float numAdds), + (totalSizeOnMapLookup / float numLookups) + ) + + Console.WriteLine("#largestMapSize = {0}, largestMapStackTrace = {1}", largestMapSize, largestMapStackTrace) + + let MapTree (k, v) = + report () numOnes <- numOnes + 1 totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 - MapTree (k,v) + MapTree(k, v) - let MapTreeNode (x, l, v, r, h) = - report() + let MapTreeNode (x, l, v, r, h) = + report () numNodes <- numNodes + 1 - let n = MapTreeNode (x, l, v, r, h) + let n = MapTreeNode(x, l, v, r, h) totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (size n) n #endif - let inline height (m: MapTree<'Key, 'Value>) = - if isEmpty m then 0 - else m.Height - + let inline height (m: MapTree<'Key, 'Value>) = + if isEmpty m then 0 else m.Height + [] let tolerance = 2 - - let mk l k v r : MapTree<'Key, 'Value> = + + let mk l k v r : MapTree<'Key, 'Value> = let hl = height l let hr = height r let m = if hl < hr then hr else hl - if m = 0 then // m=0 ~ isEmpty l && isEmpty r - MapTree(k,v) + + if m = 0 then // m=0 ~ isEmpty l && isEmpty r + MapTree(k, v) else - MapTreeNode(k,v,l,r,m+1) :> MapTree<'Key, 'Value> // new map is higher by 1 than the highest - + MapTreeNode(k, v, l, r, m + 1) :> MapTree<'Key, 'Value> // new map is higher by 1 than the highest + let rebalance t1 (k: 'Key) (v: 'Value) t2 : MapTree<'Key, 'Value> = let t1h = height t1 - let t2h = height t2 - if t2h > t1h + tolerance then (* right is heavier than left *) - let t2' = asNode(t2) + let t2h = height t2 + + if t2h > t1h + tolerance then (* right is heavier than left *) + let t2' = asNode (t2) (* one of the nodes must have height > height t1 + 1 *) - if height t2'.Left > t1h + 1 then (* balance left: combination *) - let t2l = asNode(t2'.Left) + if height t2'.Left > t1h + 1 then (* balance left: combination *) + let t2l = asNode (t2'.Left) mk (mk t1 k v t2l.Left) t2l.Key t2l.Value (mk t2l.Right t2'.Key t2'.Value t2'.Right) else (* rotate left *) mk (mk t1 k v t2'.Left) t2'.Key t2'.Value t2'.Right - else - if t1h > t2h + tolerance then (* left is heavier than right *) - let t1' = asNode(t1) - (* one of the nodes must have height > height t2 + 1 *) - if height t1'.Right > t2h + 1 then + else if t1h > t2h + tolerance then (* left is heavier than right *) + let t1' = asNode (t1) + (* one of the nodes must have height > height t2 + 1 *) + if height t1'.Right > t2h + 1 then (* balance right: combination *) - let t1r = asNode(t1'.Right) - mk (mk t1'.Left t1'.Key t1'.Value t1r.Left) t1r.Key t1r.Value (mk t1r.Right k v t2) - else - mk t1'.Left t1'.Key t1'.Value (mk t1'.Right k v t2) - else mk t1 k v t2 - - let rec add (comparer: IComparer<'Key>) k (v: 'Value) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Value> = - if isEmpty m then MapTree(k,v) + let t1r = asNode (t1'.Right) + mk (mk t1'.Left t1'.Key t1'.Value t1r.Left) t1r.Key t1r.Value (mk t1r.Right k v t2) + else + mk t1'.Left t1'.Key t1'.Value (mk t1'.Right k v t2) else - let c = comparer.Compare(k,m.Key) + mk t1 k v t2 + + let rec add (comparer: IComparer<'Key>) k (v: 'Value) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Value> = + if isEmpty m then + MapTree(k, v) + else + let c = comparer.Compare(k, m.Key) + if m.Height = 1 then - if c < 0 then MapTreeNode (k,v,empty,m,2) :> MapTree<'Key, 'Value> - elif c = 0 then MapTree(k,v) - else MapTreeNode (k,v,m,empty,2) :> MapTree<'Key, 'Value> + if c < 0 then + MapTreeNode(k, v, empty, m, 2) :> MapTree<'Key, 'Value> + elif c = 0 then + MapTree(k, v) + else + MapTreeNode(k, v, m, empty, 2) :> MapTree<'Key, 'Value> else let mn = asNode m - if c < 0 then rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right - elif c = 0 then MapTreeNode(k,v,mn.Left,mn.Right,mn.Height) :> MapTree<'Key, 'Value> - else rebalance mn.Left mn.Key mn.Value (add comparer k v mn.Right) - - let rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = - if isEmpty m then false + + if c < 0 then + rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then + MapTreeNode(k, v, mn.Left, mn.Right, mn.Height) :> MapTree<'Key, 'Value> + else + rebalance mn.Left mn.Key mn.Value (add comparer k v mn.Right) + + let rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then + false else let c = comparer.Compare(k, m.Key) - if c = 0 then v <- m.Value; true + + if c = 0 then + v <- m.Value + true + else if m.Height = 1 then + false else - if m.Height = 1 then false - else - let mn = asNode m - tryGetValue comparer k &v (if c < 0 then mn.Left else mn.Right) - + let mn = asNode m + tryGetValue comparer k &v (if c < 0 then mn.Left else mn.Right) + [] - let throwKeyNotFound() = raise (KeyNotFoundException()) - + let throwKeyNotFound () = + raise (KeyNotFoundException()) + [] let find (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> + if tryGetValue comparer k &v m then v else - throwKeyNotFound() + throwKeyNotFound () - let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> + if tryGetValue comparer k &v m then Some v else None - let partition1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v (acc1, acc2) = - if f.Invoke (k, v) then (add comparer k v acc1, acc2) else (acc1, add comparer k v acc2) - - let rec partitionAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = - if isEmpty m then acc + let partition1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v (acc1, acc2) = + if f.Invoke(k, v) then + (add comparer k v acc1, acc2) else - if m.Height = 1 then - partition1 comparer f m.Key m.Value acc - else - let mn = asNode m - let acc = partitionAux comparer f mn.Right acc - let acc = partition1 comparer f mn.Key mn.Value acc - partitionAux comparer f mn.Left acc - + (acc1, add comparer k v acc2) + + let rec partitionAux + (comparer: IComparer<'Key>) + (f: OptimizedClosures.FSharpFunc<_, _, _>) + (m: MapTree<'Key, 'Value>) + acc + = + if isEmpty m then + acc + else if m.Height = 1 then + partition1 comparer f m.Key m.Value acc + else + let mn = asNode m + let acc = partitionAux comparer f mn.Right acc + let acc = partition1 comparer f mn.Key mn.Value acc + partitionAux comparer f mn.Left acc + let partition (comparer: IComparer<'Key>) f m = partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) let filter1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v acc = - if f.Invoke (k, v) then add comparer k v acc else acc + if f.Invoke(k, v) then + add comparer k v acc + else + acc - let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = - if isEmpty m then acc + let rec filterAux + (comparer: IComparer<'Key>) + (f: OptimizedClosures.FSharpFunc<_, _, _>) + (m: MapTree<'Key, 'Value>) + acc + = + if isEmpty m then + acc + else if m.Height = 1 then + filter1 comparer f m.Key m.Value acc else - if m.Height = 1 then - filter1 comparer f m.Key m.Value acc - else - let mn = asNode m - let acc = filterAux comparer f mn.Left acc - let acc = filter1 comparer f mn.Key mn.Value acc - filterAux comparer f mn.Right acc - + let mn = asNode m + let acc = filterAux comparer f mn.Left acc + let acc = filter1 comparer f mn.Key mn.Value acc + filterAux comparer f mn.Right acc let filter (comparer: IComparer<'Key>) f m = filterAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m empty - let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = - if isEmpty m then failwith "internal error: Map.spliceOutSuccessor" + let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = + if isEmpty m then + failwith "internal error: Map.spliceOutSuccessor" + else if m.Height = 1 then + m.Key, m.Value, empty else - if m.Height = 1 then - m.Key, m.Value, empty + let mn = asNode m + + if isEmpty mn.Left then + mn.Key, mn.Value, mn.Right else - let mn = asNode m - if isEmpty mn.Left then mn.Key, mn.Value, mn.Right - else let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right + let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right - let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = - if isEmpty m then empty + let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then + empty else let c = comparer.Compare(k, m.Key) - if m.Height = 1 then + + if m.Height = 1 then if c = 0 then empty else m else - let mn = asNode m - if c < 0 then rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right + let mn = asNode m + + if c < 0 then + rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right elif c = 0 then - if isEmpty mn.Left then mn.Right - elif isEmpty mn.Right then mn.Left + if isEmpty mn.Left then + mn.Right + elif isEmpty mn.Right then + mn.Left else - let sk, sv, r' = spliceOutSuccessor mn.Right + let sk, sv, r' = spliceOutSuccessor mn.Right mk mn.Left sk sv r' - else rebalance mn.Left mn.Key mn.Value (remove comparer k mn.Right) - - - let rec change (comparer: IComparer<'Key>) k (u: 'Value option -> 'Value option) (m: MapTree<'Key, 'Value>) : MapTree<'Key,'Value> = + else + rebalance mn.Left mn.Key mn.Value (remove comparer k mn.Right) + + let rec change + (comparer: IComparer<'Key>) + k + (u: 'Value option -> 'Value option) + (m: MapTree<'Key, 'Value>) + : MapTree<'Key, 'Value> = if isEmpty m then match u None with + | None -> m + | Some v -> MapTree(k, v) + else if m.Height = 1 then + let c = comparer.Compare(k, m.Key) + + if c < 0 then + match u None with | None -> m - | Some v -> MapTree (k, v) + | Some v -> MapTreeNode(k, v, empty, m, 2) :> MapTree<'Key, 'Value> + elif c = 0 then + match u (Some m.Value) with + | None -> empty + | Some v -> MapTree(k, v) + else + match u None with + | None -> m + | Some v -> MapTreeNode(k, v, m, empty, 2) :> MapTree<'Key, 'Value> else - if m.Height = 1 then - let c = comparer.Compare(k, m.Key) - if c < 0 then - match u None with - | None -> m - | Some v -> MapTreeNode (k, v, empty, m, 2) :> MapTree<'Key,'Value> - elif c = 0 then - match u (Some m.Value) with - | None -> empty - | Some v -> MapTree (k, v) - else - match u None with - | None -> m - | Some v -> MapTreeNode (k, v, m, empty, 2) :> MapTree<'Key,'Value> + let mn = asNode m + let c = comparer.Compare(k, mn.Key) + + if c < 0 then + rebalance (change comparer k u mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then + match u (Some mn.Value) with + | None -> + if isEmpty mn.Left then + mn.Right + elif isEmpty mn.Right then + mn.Left + else + let sk, sv, r' = spliceOutSuccessor mn.Right + mk mn.Left sk sv r' + | Some v -> MapTreeNode(k, v, mn.Left, mn.Right, mn.Height) :> MapTree<'Key, 'Value> else - let mn = asNode m - let c = comparer.Compare(k, mn.Key) - if c < 0 then - rebalance (change comparer k u mn.Left) mn.Key mn.Value mn.Right - elif c = 0 then - match u (Some mn.Value) with - | None -> - if isEmpty mn.Left then mn.Right - elif isEmpty mn.Right then mn.Left - else - let sk, sv, r' = spliceOutSuccessor mn.Right - mk mn.Left sk sv r' - | Some v -> MapTreeNode (k, v, mn.Left, mn.Right, mn.Height) :> MapTree<'Key,'Value> - else - rebalance mn.Left mn.Key mn.Value (change comparer k u mn.Right) + rebalance mn.Left mn.Key mn.Value (change comparer k u mn.Right) - let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = - if isEmpty m then false + let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then + false else let c = comparer.Compare(k, m.Key) - if m.Height = 1 then + + if m.Height = 1 then c = 0 else let mn = asNode m - if c < 0 then mem comparer k mn.Left - else (c = 0 || mem comparer k mn.Right) - + + if c < 0 then + mem comparer k mn.Left + else + (c = 0 || mem comparer k mn.Right) let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = - if isEmpty m then () + if isEmpty m then + () + else if m.Height = 1 then + f.Invoke(m.Key, m.Value) else - if m.Height = 1 then - f.Invoke (m.Key, m.Value) - else - let mn = asNode m - iterOpt f mn.Left; f.Invoke (mn.Key, mn.Value); iterOpt f mn.Right - + let mn = asNode m + iterOpt f mn.Left + f.Invoke(mn.Key, mn.Value) + iterOpt f mn.Right let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m let rec tryPickOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = - if isEmpty m then None + if isEmpty m then + None + else if m.Height = 1 then + f.Invoke(m.Key, m.Value) else - if m.Height = 1 then - f.Invoke (m.Key, m.Value) - else - let mn = asNode m - match tryPickOpt f mn.Left with - | Some _ as res -> res - | None -> - match f.Invoke (mn.Key, mn.Value) with - | Some _ as res -> res - | None -> - tryPickOpt f mn.Right - + let mn = asNode m + + match tryPickOpt f mn.Left with + | Some _ as res -> res + | None -> + match f.Invoke(mn.Key, mn.Value) with + | Some _ as res -> res + | None -> tryPickOpt f mn.Right let tryPick f m = tryPickOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m - let rec existsOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = - if isEmpty m then false + let rec existsOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then + false + else if m.Height = 1 then + f.Invoke(m.Key, m.Value) else - if m.Height = 1 then - f.Invoke (m.Key, m.Value) - else - let mn = asNode m - existsOpt f mn.Left || f.Invoke (mn.Key, mn.Value) || existsOpt f mn.Right - + let mn = asNode m + existsOpt f mn.Left || f.Invoke(mn.Key, mn.Value) || existsOpt f mn.Right let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m - let rec forallOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = - if isEmpty m then true + let rec forallOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then + true + else if m.Height = 1 then + f.Invoke(m.Key, m.Value) else - if m.Height = 1 then - f.Invoke (m.Key, m.Value) - else - let mn = asNode m - forallOpt f mn.Left && f.Invoke (mn.Key, mn.Value) && forallOpt f mn.Right - - + let mn = asNode m + forallOpt f mn.Left && f.Invoke(mn.Key, mn.Value) && forallOpt f mn.Right let forall f m = forallOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m - let rec map (f:'Value -> 'Result) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Result> = - if isEmpty m then empty + let rec map (f: 'Value -> 'Result) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Result> = + if isEmpty m then + empty + else if m.Height = 1 then + MapTree(m.Key, f m.Value) else - if m.Height = 1 then - MapTree (m.Key, f m.Value) - else - let mn = asNode m - let l2 = map f mn.Left - let v2 = f mn.Value - let r2 = map f mn.Right - MapTreeNode (mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> + let mn = asNode m + let l2 = map f mn.Left + let v2 = f mn.Value + let r2 = map f mn.Right + MapTreeNode(mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> - let rec mapiOpt (f: OptimizedClosures.FSharpFunc<'Key, 'Value, 'Result>) (m: MapTree<'Key, 'Value>) = - if isEmpty m then empty + let rec mapiOpt (f: OptimizedClosures.FSharpFunc<'Key, 'Value, 'Result>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then + empty + else if m.Height = 1 then + MapTree(m.Key, f.Invoke(m.Key, m.Value)) else - if m.Height = 1 then - MapTree (m.Key, f.Invoke (m.Key, m.Value)) - else - let mn = asNode m - let l2 = mapiOpt f mn.Left - let v2 = f.Invoke (mn.Key, mn.Value) - let r2 = mapiOpt f mn.Right - MapTreeNode (mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> - + let mn = asNode m + let l2 = mapiOpt f mn.Left + let v2 = f.Invoke(mn.Key, mn.Value) + let r2 = mapiOpt f mn.Right + MapTreeNode(mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> let mapi f m = mapiOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m - let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = - if isEmpty m then x + let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + if isEmpty m then + x + else if m.Height = 1 then + f.Invoke(m.Key, m.Value, x) else - if m.Height = 1 then - f.Invoke (m.Key, m.Value, x) - else - let mn = asNode m - let x = foldBackOpt f mn.Right x - let x = f.Invoke (mn.Key, mn.Value, x) - foldBackOpt f mn.Left x - + let mn = asNode m + let x = foldBackOpt f mn.Right x + let x = f.Invoke(mn.Key, mn.Value, x) + foldBackOpt f mn.Left x let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x - let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) x (m: MapTree<'Key, 'Value>) = - if isEmpty m then x + let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) x (m: MapTree<'Key, 'Value>) = + if isEmpty m then + x + else if m.Height = 1 then + f.Invoke(x, m.Key, m.Value) else - if m.Height = 1 then - f.Invoke (x, m.Key, m.Value) - else - let mn = asNode m - let x = foldOpt f x mn.Left - let x = f.Invoke (x, mn.Key, mn.Value) - foldOpt f x mn.Right + let mn = asNode m + let x = foldOpt f x mn.Left + let x = f.Invoke(x, mn.Key, mn.Value) + foldOpt f x mn.Right let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) x m - let foldSectionOpt (comparer: IComparer<'Key>) lo hi (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = - let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = - if isEmpty m then x + let foldSectionOpt + (comparer: IComparer<'Key>) + lo + hi + (f: OptimizedClosures.FSharpFunc<_, _, _, _>) + (m: MapTree<'Key, 'Value>) + x + = + let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + if isEmpty m then + x + else if m.Height = 1 then + let cLoKey = comparer.Compare(lo, m.Key) + let cKeyHi = comparer.Compare(m.Key, hi) + + let x = + if cLoKey <= 0 && cKeyHi <= 0 then + f.Invoke(m.Key, m.Value, x) + else + x + + x else - if m.Height = 1 then - let cLoKey = comparer.Compare(lo, m.Key) - let cKeyHi = comparer.Compare(m.Key, hi) - let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (m.Key, m.Value, x) else x - x - else - let mn = asNode m - let cLoKey = comparer.Compare(lo, mn.Key) - let cKeyHi = comparer.Compare(mn.Key, hi) - let x = if cLoKey < 0 then foldFromTo f mn.Left x else x - let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (mn.Key, mn.Value, x) else x - let x = if cKeyHi < 0 then foldFromTo f mn.Right x else x - x + let mn = asNode m + let cLoKey = comparer.Compare(lo, mn.Key) + let cKeyHi = comparer.Compare(mn.Key, hi) + + let x = + if cLoKey < 0 then + foldFromTo f mn.Left x + else + x + + let x = + if cLoKey <= 0 && cKeyHi <= 0 then + f.Invoke(mn.Key, mn.Value, x) + else + x + + let x = + if cKeyHi < 0 then + foldFromTo f mn.Right x + else + x - if comparer.Compare(lo, hi) = 1 then x else foldFromTo f m x + x + + if comparer.Compare(lo, hi) = 1 then + x + else + foldFromTo f m x let foldSection (comparer: IComparer<'Key>) lo hi f m x = foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x - let toList (m: MapTree<'Key, 'Value>) = - let rec loop (m: MapTree<'Key, 'Value>) acc = - if isEmpty m then acc + let toList (m: MapTree<'Key, 'Value>) = + let rec loop (m: MapTree<'Key, 'Value>) acc = + if isEmpty m then + acc + else if m.Height = 1 then + (m.Key, m.Value) :: acc else - if m.Height = 1 then - (m.Key, m.Value) :: acc - else - let mn = asNode m - loop mn.Left ((mn.Key, mn.Value) :: loop mn.Right acc) - + let mn = asNode m + loop mn.Left ((mn.Key, mn.Value) :: loop mn.Right acc) + loop m [] let toArray m = @@ -439,78 +535,92 @@ module MapTree = let ofList comparer l = List.fold (fun acc (k, v) -> add comparer k v acc) empty l - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = - if e.MoveNext() then - let (x, y) = e.Current + let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = + if e.MoveNext() then + let (x, y) = e.Current mkFromEnumerator comparer (add comparer x y acc) e - else acc + else + acc - let ofArray comparer (arr : array<'Key * 'Value>) = + let ofArray comparer (arr: array<'Key * 'Value>) = let mutable res = empty + for (x, y) in arr do - res <- add comparer x y res + res <- add comparer x y res + res - let ofSeq comparer (c : seq<'Key * 'T>) = - match c with + let ofSeq comparer (c: seq<'Key * 'T>) = + match c with | :? (('Key * 'T)[]) as xs -> ofArray comparer xs | :? (('Key * 'T) list) as xs -> ofList comparer xs - | _ -> + | _ -> use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie + mkFromEnumerator comparer empty ie let copyToArray m (arr: _[]) i = - let mutable j = i - m |> iter (fun x y -> arr.[j] <- KeyValuePair(x, y); j <- j + 1) + let mutable j = i + + m + |> iter (fun x y -> + arr.[j] <- KeyValuePair(x, y) + j <- j + 1) /// Imperative left-to-right iterators. [] - type MapIterator<'Key, 'Value when 'Key : comparison > = - { /// invariant: always collapseLHS result - mutable stack: MapTree<'Key, 'Value> list + type MapIterator<'Key, 'Value when 'Key: comparison> = + { + /// invariant: always collapseLHS result + mutable stack: MapTree<'Key, 'Value> list - /// true when MoveNext has been called - mutable started : bool } + /// true when MoveNext has been called + mutable started: bool + } // collapseLHS: // a) Always returns either [] or a list starting with MapOne. - // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS (stack:MapTree<'Key, 'Value> list) = + // b) The "fringe" of the set stack is unchanged. + let rec collapseLHS (stack: MapTree<'Key, 'Value> list) = match stack with | [] -> [] | m :: rest -> - if isEmpty m then collapseLHS rest + if isEmpty m then + collapseLHS rest + else if m.Height = 1 then + stack else - if m.Height = 1 then - stack - else - let mn = asNode m - collapseLHS (mn.Left :: MapTree (mn.Key, mn.Value) :: mn.Right :: rest) + let mn = asNode m + collapseLHS (mn.Left :: MapTree(mn.Key, mn.Value) :: mn.Right :: rest) let mkIterator m = - { stack = collapseLHS [m]; started = false } + { + stack = collapseLHS [ m ] + started = false + } - let notStarted() = + let notStarted () = raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = + let alreadyFinished () = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) - - let unexpectedStackForCurrent() = + + let unexpectedStackForCurrent () = failwith "Please report error: Map iterator, unexpected stack for current" - - let unexpectedStackForMoveNext() = + + let unexpectedStackForMoveNext () = failwith "Please report error: Map iterator, unexpected stack for moveNext" let current i = if i.started then match i.stack with - | [] -> alreadyFinished() + | [] -> alreadyFinished () | m :: _ -> - if m.Height = 1 then KeyValuePair<_, _>(m.Key, m.Value) - else unexpectedStackForCurrent() + if m.Height = 1 then + KeyValuePair<_, _>(m.Key, m.Value) + else + unexpectedStackForCurrent () else - notStarted() + notStarted () let rec moveNext i = if i.started then @@ -520,54 +630,70 @@ module MapTree = if m.Height = 1 then i.stack <- collapseLHS rest not i.stack.IsEmpty - else unexpectedStackForMoveNext() + else + unexpectedStackForMoveNext () else - i.started <- true (* The first call to MoveNext "starts" the enumeration. *) + i.started <- true (* The first call to MoveNext "starts" the enumeration. *) not i.stack.IsEmpty - let mkIEnumerator m = - let mutable i = mkIterator m - { new IEnumerator<_> with - member _.Current = current i + let mkIEnumerator m = + let mutable i = mkIterator m + { new IEnumerator<_> with + member _.Current = current i interface System.Collections.IEnumerator with member _.Current = box (current i) - member _.MoveNext() = moveNext i - member _.Reset() = i <- mkIterator m - interface System.IDisposable with - member _.Dispose() = ()} + member _.MoveNext() = + moveNext i + + member _.Reset() = + i <- mkIterator m + interface System.IDisposable with + member _.Dispose() = + () + } let rec leftmost m = - if isEmpty m then - throwKeyNotFound() + if isEmpty m then + throwKeyNotFound () else if m.Height = 1 then (m.Key, m.Value) else - let nd = asNode m - if isNull nd.Left then (m.Key, m.Value) - else leftmost nd.Left - + let nd = asNode m + + if isNull nd.Left then + (m.Key, m.Value) + else + leftmost nd.Left + let rec rightmost m = - if isEmpty m then - throwKeyNotFound() + if isEmpty m then + throwKeyNotFound () else if m.Height = 1 then (m.Key, m.Value) else - let nd = asNode m - if isNull nd.Right then (m.Key, m.Value) - else rightmost nd.Right + let nd = asNode m + + if isNull nd.Right then + (m.Key, m.Value) + else + rightmost nd.Right [>)>] [] [] [] -type Map<[]'Key, []'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key, 'Value>) = +type Map<[] 'Key, [] 'Value when 'Key: comparison> + ( + comparer: IComparer<'Key>, + tree: MapTree<'Key, 'Value> + ) = [] // This type is logically immutable. This field is only mutated during deserialization. let mutable comparer = comparer - + [] // This type is logically immutable. This field is only mutated during deserialization. let mutable tree = tree @@ -580,8 +706,8 @@ type Map<[]'Key, [ + static let empty = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> new Map<'Key, 'Value>(comparer, MapTree.empty) [] @@ -598,18 +724,22 @@ type Map<[]'Key, [ - tree <- serializedData |> Array.map (fun kvp -> kvp.Key, kvp.Value) |> MapTree.ofArray comparer + + tree <- + serializedData + |> Array.map (fun kvp -> kvp.Key, kvp.Value) + |> MapTree.ofArray comparer + serializedData <- null - static member Empty : Map<'Key, 'Value> = - empty + static member Empty: Map<'Key, 'Value> = empty - static member Create(ie : IEnumerable<_>) : Map<'Key, 'Value> = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> + static member Create(ie: IEnumerable<_>) : Map<'Key, 'Value> = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> new Map<_, _>(comparer, MapTree.ofSeq comparer ie) - new (elements : seq<_>) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new(elements: seq<_>) = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> new Map<_, _>(comparer, MapTree.ofSeq comparer elements) [] @@ -618,13 +748,14 @@ type Map<[]'Key, [] member internal m.Tree = tree - member m.Add(key, value) : Map<'Key, 'Value> = + member m.Add(key, value) : Map<'Key, 'Value> = #if TRACE_SETS_AND_MAPS - MapTree.report() + MapTree.report () MapTree.numAdds <- MapTree.numAdds + 1 let size = MapTree.size m.Tree + 1 MapTree.totalSizeOnMapAdd <- MapTree.totalSizeOnMapAdd + float size - if size > MapTree.largestMapSize then + + if size > MapTree.largestMapSize then MapTree.largestMapSize <- size MapTree.largestMapStackTrace <- System.Diagnostics.StackTrace().ToString() #endif @@ -636,66 +767,65 @@ type Map<[]'Key, [] member m.IsEmpty = MapTree.isEmpty tree - member m.Item - with get(key : 'Key) = + member m.Item + with get (key: 'Key) = #if TRACE_SETS_AND_MAPS - MapTree.report() - MapTree.numLookups <- MapTree.numLookups + 1 - MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) + MapTree.report () + MapTree.numLookups <- MapTree.numLookups + 1 + MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) #endif - MapTree.find comparer key tree + MapTree.find comparer key tree member m.TryPick f = - MapTree.tryPick f tree + MapTree.tryPick f tree member m.Exists predicate = - MapTree.exists predicate tree + MapTree.exists predicate tree member m.Filter predicate = new Map<'Key, 'Value>(comparer, MapTree.filter comparer predicate tree) member m.ForAll predicate = - MapTree.forall predicate tree + MapTree.forall predicate tree member m.Fold f acc = MapTree.foldBack f tree acc - member m.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = - MapTree.foldSection comparer lo hi f tree acc + member m.FoldSection (lo: 'Key) (hi: 'Key) f (acc: 'z) = + MapTree.foldSection comparer lo hi f tree acc member m.Iterate f = MapTree.iter f tree - member m.MapRange (f:'Value->'Result) = + member m.MapRange(f: 'Value -> 'Result) = new Map<'Key, 'Result>(comparer, MapTree.map f tree) member m.Map f = new Map<'Key, 'b>(comparer, MapTree.mapi f tree) - member m.Partition predicate : Map<'Key, 'Value> * Map<'Key, 'Value> = + member m.Partition predicate : Map<'Key, 'Value> * Map<'Key, 'Value> = let r1, r2 = MapTree.partition comparer predicate tree new Map<'Key, 'Value>(comparer, r1), new Map<'Key, 'Value>(comparer, r2) - member m.Count = - MapTree.size tree + member m.Count = MapTree.size tree - member m.ContainsKey key = + member m.ContainsKey key = #if TRACE_SETS_AND_MAPS - MapTree.report() + MapTree.report () MapTree.numLookups <- MapTree.numLookups + 1 MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) #endif MapTree.mem comparer key tree - member m.Remove key = + member m.Remove key = new Map<'Key, 'Value>(comparer, MapTree.remove comparer key tree) - member m.TryGetValue(key, [] value: byref<'Value>) = + member m.TryGetValue(key, [] value: byref<'Value>) = MapTree.tryGetValue comparer key &value tree - member m.TryFind key = + member m.TryFind key = #if TRACE_SETS_AND_MAPS - MapTree.report() + MapTree.report () MapTree.numLookups <- MapTree.numLookups + 1 MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) #endif @@ -708,209 +838,296 @@ type Map<[]'Key, [ ICollection<'Key> - + member m.Values = ValueCollection(m) :> ICollection<'Value> - + member m.MinKeyValue = MapTree.leftmost tree member m.MaxKeyValue = MapTree.rightmost tree - static member ofList l : Map<'Key, 'Value> = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofList comparer l) + static member ofList l : Map<'Key, 'Value> = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofList comparer l) + + member this.ComputeHashCode() = + let combineHash x y = + (x <<< 1) + y + 631 - member this.ComputeHashCode() = - let combineHash x y = (x <<< 1) + y + 631 let mutable res = 0 - for (KeyValue(x, y)) in this do + + for (KeyValue (x, y)) in this do res <- combineHash res (hash x) res <- combineHash res (Unchecked.hash y) + res - override this.Equals that = - match that with - | :? Map<'Key, 'Value> as that -> - use e1 = (this :> seq<_>).GetEnumerator() - use e2 = (that :> seq<_>).GetEnumerator() - let rec loop () = - let m1 = e1.MoveNext() + override this.Equals that = + match that with + | :? Map<'Key, 'Value> as that -> + use e1 = (this :> seq<_>).GetEnumerator() + use e2 = (that :> seq<_>).GetEnumerator() + + let rec loop () = + let m1 = e1.MoveNext() let m2 = e2.MoveNext() - (m1 = m2) && (not m1 || - (let e1c = e1.Current - let e2c = e2.Current - ((e1c.Key = e2c.Key) && (Unchecked.equals e1c.Value e2c.Value) && loop()))) - loop() + + (m1 = m2) + && (not m1 + || (let e1c = e1.Current + let e2c = e2.Current + ((e1c.Key = e2c.Key) && (Unchecked.equals e1c.Value e2c.Value) && loop ()))) + + loop () | _ -> false - override this.GetHashCode() = this.ComputeHashCode() + override this.GetHashCode() = + this.ComputeHashCode() interface IEnumerable> with - member _.GetEnumerator() = MapTree.mkIEnumerator tree + member _.GetEnumerator() = + MapTree.mkIEnumerator tree interface IEnumerable with - member _.GetEnumerator() = (MapTree.mkIEnumerator tree :> IEnumerator) + member _.GetEnumerator() = + (MapTree.mkIEnumerator tree :> IEnumerator) - interface IDictionary<'Key, 'Value> with - member m.Item - with get x = m.[x] - and set _ _ = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + interface IDictionary<'Key, 'Value> with + member m.Item + with get x = m.[x] + and set _ _ = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) member m.Keys = m.Keys member m.Values = m.Values - member m.Add(_, _) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member m.Add(_, _) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.ContainsKey k = m.ContainsKey k + member m.ContainsKey k = + m.ContainsKey k - member m.TryGetValue(k, r) = m.TryGetValue(k, &r) + member m.TryGetValue(k, r) = + m.TryGetValue(k, &r) - member m.Remove(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member m.Remove(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - interface ICollection> with - member _.Add(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + interface ICollection> with + member _.Add(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Clear() = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Clear() = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Remove(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Remove(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.Contains x = m.ContainsKey x.Key && Unchecked.equals m.[x.Key] x.Value + member m.Contains x = + m.ContainsKey x.Key && Unchecked.equals m.[x.Key] x.Value - member _.CopyTo(arr, i) = MapTree.copyToArray tree arr i + member _.CopyTo(arr, i) = + MapTree.copyToArray tree arr i member _.IsReadOnly = true member m.Count = m.Count - interface System.IComparable with - member m.CompareTo(obj: obj) = - match obj with - | :? Map<'Key, 'Value> as m2-> - Seq.compareWith - (fun (kvp1 : KeyValuePair<_, _>) (kvp2 : KeyValuePair<_, _>)-> - let c = comparer.Compare(kvp1.Key, kvp2.Key) in - if c <> 0 then c else Unchecked.compare kvp1.Value kvp2.Value) - m m2 - | _ -> - invalidArg "obj" (SR.GetString(SR.notComparable)) + interface System.IComparable with + member m.CompareTo(obj: obj) = + match obj with + | :? Map<'Key, 'Value> as m2 -> + Seq.compareWith + (fun (kvp1: KeyValuePair<_, _>) (kvp2: KeyValuePair<_, _>) -> + let c = comparer.Compare(kvp1.Key, kvp2.Key) in + + if c <> 0 then + c + else + Unchecked.compare kvp1.Value kvp2.Value) + m + m2 + | _ -> invalidArg "obj" (SR.GetString(SR.notComparable)) interface IReadOnlyCollection> with member m.Count = m.Count interface IReadOnlyDictionary<'Key, 'Value> with - member m.Item with get key = m.[key] + member m.Item + with get key = m.[key] member m.Keys = m.Keys :> IEnumerable<'Key> - member m.TryGetValue(key, value: byref<'Value>) = m.TryGetValue(key, &value) + member m.TryGetValue(key, value: byref<'Value>) = + m.TryGetValue(key, &value) member m.Values = m.Values :> IEnumerable<'Value> - member m.ContainsKey key = m.ContainsKey key + member m.ContainsKey key = + m.ContainsKey key - override x.ToString() = - match List.ofSeq (Seq.truncate 4 x) with + override x.ToString() = + match List.ofSeq (Seq.truncate 4 x) with | [] -> "map []" - | [KeyValue h1] -> + | [ KeyValue h1 ] -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 StringBuilder().Append("map [").Append(txt1).Append("]").ToString() - | [KeyValue h1; KeyValue h2] -> + | [ KeyValue h1; KeyValue h2 ] -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 let txt2 = LanguagePrimitives.anyToStringShowingNull h2 - StringBuilder().Append("map [").Append(txt1).Append("; ").Append(txt2).Append("]").ToString() - | [KeyValue h1; KeyValue h2; KeyValue h3] -> + + StringBuilder() + .Append("map [") + .Append(txt1) + .Append("; ") + .Append(txt2) + .Append("]") + .ToString() + | [ KeyValue h1; KeyValue h2; KeyValue h3 ] -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 let txt2 = LanguagePrimitives.anyToStringShowingNull h2 let txt3 = LanguagePrimitives.anyToStringShowingNull h3 - StringBuilder().Append("map [").Append(txt1).Append("; ").Append(txt2).Append("; ").Append(txt3).Append("]").ToString() + + StringBuilder() + .Append("map [") + .Append(txt1) + .Append("; ") + .Append(txt2) + .Append("; ") + .Append(txt3) + .Append("]") + .ToString() | KeyValue h1 :: KeyValue h2 :: KeyValue h3 :: _ -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 let txt2 = LanguagePrimitives.anyToStringShowingNull h2 let txt3 = LanguagePrimitives.anyToStringShowingNull h3 - StringBuilder().Append("map [").Append(txt1).Append("; ").Append(txt2).Append("; ").Append(txt3).Append("; ... ]").ToString() -and - [] - MapDebugView<'Key, 'Value when 'Key : comparison>(v: Map<'Key, 'Value>) = + StringBuilder() + .Append("map [") + .Append(txt1) + .Append("; ") + .Append(txt2) + .Append("; ") + .Append(txt3) + .Append("; ... ]") + .ToString() + +and [] MapDebugView<'Key, 'Value when 'Key: comparison>(v: Map<'Key, 'Value>) = - [] - member x.Items = - v |> Seq.truncate 10000 |> Seq.map KeyValuePairDebugFriendly |> Seq.toArray + [] + member x.Items = + v |> Seq.truncate 10000 |> Seq.map KeyValuePairDebugFriendly |> Seq.toArray -and - [] - KeyValuePairDebugFriendly<'Key, 'Value>(keyValue : KeyValuePair<'Key, 'Value>) = +and [] KeyValuePairDebugFriendly<'Key, 'Value> + ( + keyValue: KeyValuePair<'Key, 'Value> + ) = - [] - member x.KeyValue = keyValue + [] + member x.KeyValue = keyValue -and KeyCollection<'Key, 'Value when 'Key : comparison>(parent: Map<'Key, 'Value>) = +and KeyCollection<'Key, 'Value when 'Key: comparison>(parent: Map<'Key, 'Value>) = interface ICollection<'Key> with - member _.Add(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - - member _.Clear() = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Add(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Remove(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Clear() = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Contains x = parent.ContainsKey x + member _.Remove(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + + member _.Contains x = + parent.ContainsKey x member _.CopyTo(arr, index) = if isNull arr then nullArg "arr" - if index < 0 then invalidArg "index" "index must be positive" - if index + parent.Count > arr.Length then invalidArg "index" "array is smaller than index plus the number of items to copy" - + + if index < 0 then + invalidArg "index" "index must be positive" + + if index + parent.Count > arr.Length then + invalidArg "index" "array is smaller than index plus the number of items to copy" + let mutable i = index - for item in parent do + + for item in parent do arr.[i] <- item.Key i <- i + 1 member _.IsReadOnly = true member _.Count = parent.Count - + interface IEnumerable<'Key> with member _.GetEnumerator() = - (seq { for item in parent do item.Key}).GetEnumerator() - + (seq { + for item in parent do + item.Key + }) + .GetEnumerator() + interface IEnumerable with - member _.GetEnumerator() = - (seq { for item in parent do item.Key}).GetEnumerator() :> IEnumerator - -and ValueCollection<'Key, 'Value when 'Key : comparison>(parent: Map<'Key, 'Value>) = + member _.GetEnumerator() = + (seq { + for item in parent do + item.Key + }) + .GetEnumerator() + :> IEnumerator + +and ValueCollection<'Key, 'Value when 'Key: comparison>(parent: Map<'Key, 'Value>) = interface ICollection<'Value> with - member _.Add(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Add(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Clear() = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Clear() = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Remove(_) = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) + member _.Remove(_) = + raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member _.Contains x = parent.Exists(fun _ value -> Unchecked.equals value x) + member _.Contains x = + parent.Exists(fun _ value -> Unchecked.equals value x) - member _.CopyTo(arr, index) = + member _.CopyTo(arr, index) = if isNull arr then nullArg "arr" - if index < 0 then invalidArg "index" "index must be positive" - if index + parent.Count > arr.Length then invalidArg "index" "array is smaller than index plus the number of items to copy" - + + if index < 0 then + invalidArg "index" "index must be positive" + + if index + parent.Count > arr.Length then + invalidArg "index" "array is smaller than index plus the number of items to copy" + let mutable i = index - for item in parent do + + for item in parent do arr.[i] <- item.Value i <- i + 1 member _.IsReadOnly = true member _.Count = parent.Count - + interface IEnumerable<'Value> with member _.GetEnumerator() = - (seq { for item in parent do item.Value}).GetEnumerator() - + (seq { + for item in parent do + item.Value + }) + .GetEnumerator() + interface IEnumerable with - member _.GetEnumerator() = - (seq { for item in parent do item.Value }).GetEnumerator() :> IEnumerator + member _.GetEnumerator() = + (seq { + for item in parent do + item.Value + }) + .GetEnumerator() + :> IEnumerator [] [] -module Map = +module Map = [] let isEmpty (table: Map<_, _>) = @@ -918,11 +1135,11 @@ module Map = [] let add key value (table: Map<_, _>) = - table.Add (key, value) + table.Add(key, value) [] let change key f (table: Map<_, _>) = - table.Change (key, f) + table.Change(key, f) [] let find key (table: Map<_, _>) = @@ -975,11 +1192,11 @@ module Map = table.Map mapping [] - let fold<'Key, 'T, 'State when 'Key : comparison> folder (state:'State) (table: Map<'Key, 'T>) = + let fold<'Key, 'T, 'State when 'Key: comparison> folder (state: 'State) (table: Map<'Key, 'T>) = MapTree.fold folder state table.Tree [] - let foldBack<'Key, 'T, 'State when 'Key : comparison> folder (table: Map<'Key, 'T>) (state:'State) = + let foldBack<'Key, 'T, 'State when 'Key: comparison> folder (table: Map<'Key, 'T>) (state: 'State) = MapTree.foldBack folder table.Tree state [] @@ -987,12 +1204,26 @@ module Map = table |> Seq.map (fun kvp -> kvp.Key, kvp.Value) [] - let findKey predicate (table : Map<_, _>) = - table |> Seq.pick (fun kvp -> let k = kvp.Key in if predicate k kvp.Value then Some k else None) + let findKey predicate (table: Map<_, _>) = + table + |> Seq.pick (fun kvp -> + let k = kvp.Key in + + if predicate k kvp.Value then + Some k + else + None) [] - let tryFindKey predicate (table : Map<_, _>) = - table |> Seq.tryPick (fun kvp -> let k = kvp.Key in if predicate k kvp.Value then Some k else None) + let tryFindKey predicate (table: Map<_, _>) = + table + |> Seq.tryPick (fun kvp -> + let k = kvp.Key in + + if predicate k kvp.Value then + Some k + else + None) [] let ofList (elements: ('Key * 'Value) list) = @@ -1003,9 +1234,9 @@ module Map = Map<_, _>.Create elements [] - let ofArray (elements: ('Key * 'Value) array) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofArray comparer elements) + let ofArray (elements: ('Key * 'Value) array) = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofArray comparer elements) [] let toList (table: Map<_, _>) = @@ -1016,21 +1247,24 @@ module Map = table.ToArray() [] - let empty<'Key, 'Value when 'Key : comparison> = - Map<'Key, 'Value>.Empty + let empty<'Key, 'Value when 'Key: comparison> = Map<'Key, 'Value>.Empty [] let count (table: Map<_, _>) = table.Count [] - let keys (table: Map<_, _>) = table.Keys + let keys (table: Map<_, _>) = + table.Keys [] - let values (table: Map<_, _>) = table.Values - + let values (table: Map<_, _>) = + table.Values + [] - let minKeyValue (table: Map<_,_>) = table.MinKeyValue + let minKeyValue (table: Map<_, _>) = + table.MinKeyValue [] - let maxKeyValue (table: Map<_,_>) = table.MaxKeyValue + let maxKeyValue (table: Map<_, _>) = + table.MaxKeyValue diff --git a/src/FSharp.Core/map.fsi b/src/FSharp.Core/map.fsi index d500c9a0ebe..eae4943b5b8 100644 --- a/src/FSharp.Core/map.fsi +++ b/src/FSharp.Core/map.fsi @@ -484,8 +484,9 @@ module Map = /// Evaluates to "1 a 2 b initial" /// [] - val foldBack<'Key, 'T, 'State> : folder: ('Key -> 'T -> 'State -> 'State) -> table: Map<'Key, 'T> -> state: 'State -> 'State - when 'Key: comparison + val foldBack<'Key, 'T, 'State> : + folder: ('Key -> 'T -> 'State -> 'State) -> table: Map<'Key, 'T> -> state: 'State -> 'State + when 'Key: comparison /// Folds over the bindings in the map /// @@ -504,8 +505,9 @@ module Map = /// Evaluates to "initial 1 a 2 b". /// [] - val fold<'Key, 'T, 'State> : folder: ('State -> 'Key -> 'T -> 'State) -> state: 'State -> table: Map<'Key, 'T> -> 'State - when 'Key: comparison + val fold<'Key, 'T, 'State> : + folder: ('State -> 'Key -> 'T -> 'State) -> state: 'State -> table: Map<'Key, 'T> -> 'State + when 'Key: comparison /// Applies the given function to each binding in the dictionary /// diff --git a/src/FSharp.Core/math/z.fs b/src/FSharp.Core/math/z.fs index b79ad3671fd..28d0deead19 100644 --- a/src/FSharp.Core/math/z.fs +++ b/src/FSharp.Core/math/z.fs @@ -26,60 +26,64 @@ open System.Numerics [] module NumericLiterals = - module NumericLiteralI = - - let tab64 = new System.Collections.Generic.Dictionary() - let tabParse = new System.Collections.Generic.Dictionary() - - let FromInt64Dynamic (value:int64) : obj = - lock tab64 (fun () -> - let mutable res = Unchecked.defaultof<_> - let ok = tab64.TryGetValue(value,&res) - if ok then res else - res <- BigInteger(value) - tab64.[value] <- res - res) - - let inline get32 (x32:int32) = FromInt64Dynamic (int64 x32) - - let inline isOX s = not (System.String.IsNullOrEmpty(s)) && s.Length > 2 && s.[0] = '0' && s.[1] = 'x' - - let FromZero () : 'T = - (get32 0 :?> 'T) - when 'T : BigInteger = BigInteger.Zero - - let FromOne () : 'T = - (get32 1 :?> 'T) - when 'T : BigInteger = BigInteger.One - - let FromInt32 (value:int32): 'T = - (get32 value :?> 'T) - when 'T : BigInteger = new BigInteger(value) - - let FromInt64 (value:int64): 'T = - (FromInt64Dynamic value :?> 'T) - when 'T : BigInteger = new BigInteger(value) - - let getParse s = - lock tabParse (fun () -> - let mutable res = Unchecked.defaultof<_> - let ok = tabParse.TryGetValue(s,&res) - if ok then - res - else - let v = - if isOX s then - BigInteger.Parse (s.[2..],NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture) - else - BigInteger.Parse (s,NumberStyles.AllowLeadingSign,CultureInfo.InvariantCulture) - res <- v - tabParse.[s] <- res - res) - - let FromStringDynamic (text:string) : obj = + module NumericLiteralI = + + let tab64 = new System.Collections.Generic.Dictionary() + let tabParse = new System.Collections.Generic.Dictionary() + + let FromInt64Dynamic (value: int64) : obj = + lock tab64 (fun () -> + let mutable res = Unchecked.defaultof<_> + let ok = tab64.TryGetValue(value, &res) + + if ok then + res + else + res <- BigInteger(value) + tab64.[value] <- res + res) + + let inline get32 (x32: int32) = + FromInt64Dynamic(int64 x32) + + let inline isOX s = + not (System.String.IsNullOrEmpty(s)) + && s.Length > 2 + && s.[0] = '0' + && s.[1] = 'x' + + let FromZero () : 'T = + (get32 0 :?> 'T) when 'T: BigInteger = BigInteger.Zero + + let FromOne () : 'T = + (get32 1 :?> 'T) when 'T: BigInteger = BigInteger.One + + let FromInt32 (value: int32) : 'T = + (get32 value :?> 'T) when 'T: BigInteger = new BigInteger(value) + + let FromInt64 (value: int64) : 'T = + (FromInt64Dynamic value :?> 'T) when 'T: BigInteger = new BigInteger(value) + + let getParse s = + lock tabParse (fun () -> + let mutable res = Unchecked.defaultof<_> + let ok = tabParse.TryGetValue(s, &res) + + if ok then + res + else + let v = + if isOX s then + BigInteger.Parse(s.[2..], NumberStyles.AllowHexSpecifier, CultureInfo.InvariantCulture) + else + BigInteger.Parse(s, NumberStyles.AllowLeadingSign, CultureInfo.InvariantCulture) + + res <- v + tabParse.[s] <- res + res) + + let FromStringDynamic (text: string) : obj = getParse text - - let FromString (text:string) : 'T = - (FromStringDynamic text :?> 'T) - when 'T : BigInteger = getParse text + let FromString (text: string) : 'T = + (FromStringDynamic text :?> 'T) when 'T: BigInteger = getParse text diff --git a/src/FSharp.Core/observable.fs b/src/FSharp.Core/observable.fs index 4e5af5232c7..d1bcd160313 100644 --- a/src/FSharp.Core/observable.fs +++ b/src/FSharp.Core/observable.fs @@ -12,7 +12,11 @@ open Microsoft.FSharp.Control module Observable = let inline protect f succeed fail = - match (try Choice1Of2 (f ()) with e -> Choice2Of2 e) with + match (try + Choice1Of2(f ()) + with e -> + Choice2Of2 e) + with | Choice1Of2 x -> (succeed x) | Choice2Of2 e -> (fail e) @@ -21,55 +25,67 @@ module Observable = let mutable stopped = false - abstract Next : value : 'T -> unit + abstract Next: value: 'T -> unit - abstract Error : error : exn -> unit + abstract Error: error: exn -> unit - abstract Completed : unit -> unit + abstract Completed: unit -> unit interface IObserver<'T> with - member x.OnNext value = - if not stopped then - x.Next value + member x.OnNext value = + if not stopped then x.Next value - member x.OnError e = - if not stopped then + member x.OnError e = + if not stopped then stopped <- true x.Error e - member x.OnCompleted () = - if not stopped then - stopped <- true - x.Completed () + member x.OnCompleted() = + if not stopped then + stopped <- true + x.Completed() [] let map mapping (source: IObservable<'T>) = - { new IObservable<'U> with - member x.Subscribe(observer) = - source.Subscribe - { new BasicObserver<'T>() with - - member x.Next(v) = - protect (fun () -> mapping v) observer.OnNext observer.OnError - - member x.Error(e) = observer.OnError(e) - - member x.Completed() = observer.OnCompleted() } } + { new IObservable<'U> with + member x.Subscribe(observer) = + source.Subscribe + { new BasicObserver<'T>() with - [] - let choose chooser (source: IObservable<'T>) = - { new IObservable<'U> with - member x.Subscribe(observer) = - source.Subscribe - { new BasicObserver<'T>() with + member x.Next(v) = + protect (fun () -> mapping v) observer.OnNext observer.OnError - member x.Next(v) = - protect (fun () -> chooser v) (function None -> () | Some v2 -> observer.OnNext v2) observer.OnError + member x.Error(e) = + observer.OnError(e) - member x.Error(e) = observer.OnError(e) + member x.Completed() = + observer.OnCompleted() + } + } - member x.Completed() = observer.OnCompleted() } } + [] + let choose chooser (source: IObservable<'T>) = + { new IObservable<'U> with + member x.Subscribe(observer) = + source.Subscribe + { new BasicObserver<'T>() with + + member x.Next(v) = + protect + (fun () -> chooser v) + (function + | None -> () + | Some v2 -> observer.OnNext v2) + observer.OnError + + member x.Error(e) = + observer.OnError(e) + + member x.Completed() = + observer.OnCompleted() + } + } [] let filter predicate (source: IObservable<'T>) = @@ -81,97 +97,129 @@ module Observable = [] let scan collector state (source: IObservable<'T>) = - { new IObservable<'U> with - member x.Subscribe(observer) = - let mutable state = state - source.Subscribe - { new BasicObserver<'T>() with - - member x.Next(v) = - let z = state - protect (fun () -> collector z v) (fun z -> - state <- z - observer.OnNext z) observer.OnError - - member x.Error(e) = observer.OnError(e) - - member x.Completed() = observer.OnCompleted() } } + { new IObservable<'U> with + member x.Subscribe(observer) = + let mutable state = state + + source.Subscribe + { new BasicObserver<'T>() with + + member x.Next(v) = + let z = state + + protect + (fun () -> collector z v) + (fun z -> + state <- z + observer.OnNext z) + observer.OnError + + member x.Error(e) = + observer.OnError(e) + + member x.Completed() = + observer.OnCompleted() + } + } [] - let add callback (source: IObservable<'T>) = source.Add(callback) + let add callback (source: IObservable<'T>) = + source.Add(callback) [] - let subscribe (callback: 'T -> unit) (source: IObservable<'T>) = source.Subscribe(callback) + let subscribe (callback: 'T -> unit) (source: IObservable<'T>) = + source.Subscribe(callback) [] - let pairwise (source : IObservable<'T>) : IObservable<'T * 'T> = - { new IObservable<_> with - member x.Subscribe(observer) = - let mutable lastArgs = None - source.Subscribe - { new BasicObserver<'T>() with + let pairwise (source: IObservable<'T>) : IObservable<'T * 'T> = + { new IObservable<_> with + member x.Subscribe(observer) = + let mutable lastArgs = None - member x.Next(args2) = - match lastArgs with - | None -> () - | Some args1 -> observer.OnNext (args1,args2) - lastArgs <- Some args2 + source.Subscribe + { new BasicObserver<'T>() with - member x.Error(e) = observer.OnError(e) + member x.Next(args2) = + match lastArgs with + | None -> () + | Some args1 -> observer.OnNext(args1, args2) - member x.Completed() = observer.OnCompleted() } } + lastArgs <- Some args2 + + member x.Error(e) = + observer.OnError(e) + + member x.Completed() = + observer.OnCompleted() + } + } [] let merge (source1: IObservable<'T>) (source2: IObservable<'T>) = - { new IObservable<_> with - member x.Subscribe(observer) = - let mutable stopped = false - let mutable completed1 = false - let mutable completed2 = false - let h1 = - source1.Subscribe - { new IObserver<'T> with - member x.OnNext(v) = - if not stopped then - observer.OnNext v - - member x.OnError(e) = - if not stopped then - stopped <- true - observer.OnError(e) - - member x.OnCompleted() = - if not stopped then - completed1 <- true - if completed1 && completed2 then - stopped <- true - observer.OnCompleted() } - let h2 = - source2.Subscribe - { new IObserver<'T> with - member x.OnNext(v) = - if not stopped then - observer.OnNext v - - member x.OnError(e) = - if not stopped then - stopped <- true - observer.OnError(e) - - member x.OnCompleted() = - if not stopped then - completed2 <- true - if completed1 && completed2 then - stopped <- true - observer.OnCompleted() } - - { new IDisposable with - member x.Dispose() = - h1.Dispose() - h2.Dispose() } } + { new IObservable<_> with + member x.Subscribe(observer) = + let mutable stopped = false + let mutable completed1 = false + let mutable completed2 = false + + let h1 = + source1.Subscribe + { new IObserver<'T> with + member x.OnNext(v) = + if not stopped then observer.OnNext v + + member x.OnError(e) = + if not stopped then + stopped <- true + observer.OnError(e) + + member x.OnCompleted() = + if not stopped then + completed1 <- true + + if completed1 && completed2 then + stopped <- true + observer.OnCompleted() + } + + let h2 = + source2.Subscribe + { new IObserver<'T> with + member x.OnNext(v) = + if not stopped then observer.OnNext v + + member x.OnError(e) = + if not stopped then + stopped <- true + observer.OnError(e) + + member x.OnCompleted() = + if not stopped then + completed2 <- true + + if completed1 && completed2 then + stopped <- true + observer.OnCompleted() + } + + { new IDisposable with + member x.Dispose() = + h1.Dispose() + h2.Dispose() + } + } [] - let split (splitter : 'T -> Choice<'U1,'U2>) (source: IObservable<'T>) = - choose (fun v -> match splitter v with Choice1Of2 x -> Some x | _ -> None) source, - choose (fun v -> match splitter v with Choice2Of2 x -> Some x | _ -> None) source - + let split (splitter: 'T -> Choice<'U1, 'U2>) (source: IObservable<'T>) = + choose + (fun v -> + match splitter v with + | Choice1Of2 x -> Some x + | _ -> None) + source, + choose + (fun v -> + match splitter v with + | Choice2Of2 x -> Some x + | _ -> None) + source diff --git a/src/FSharp.Core/option.fs b/src/FSharp.Core/option.fs index 8b28af7531d..720ac9d1c45 100644 --- a/src/FSharp.Core/option.fs +++ b/src/FSharp.Core/option.fs @@ -5,7 +5,7 @@ namespace Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators [] -module Option = +module Option = [] let get option = @@ -56,13 +56,13 @@ module Option = | Some _ -> 1 [] - let fold<'T,'State> folder (state:'State) (option: 'T option) = + let fold<'T, 'State> folder (state: 'State) (option: 'T option) = match option with | None -> state | Some x -> folder state x [] - let foldBack<'T,'State> folder (option: option<'T>) (state:'State) = + let foldBack<'T, 'State> folder (option: option<'T>) (state: 'State) = match option with | None -> state | Some x -> folder x state @@ -95,18 +95,18 @@ module Option = let map mapping option = match option with | None -> None - | Some x -> Some (mapping x) + | Some x -> Some(mapping x) [] - let map2 mapping option1 option2 = + let map2 mapping option1 option2 = match option1, option2 with - | Some x, Some y -> Some (mapping x y) + | Some x, Some y -> Some(mapping x y) | _ -> None [] - let map3 mapping option1 option2 option3 = + let map3 mapping option1 option2 option3 = match option1, option2, option3 with - | Some x, Some y, Some z -> Some (mapping x y z) + | Some x, Some y, Some z -> Some(mapping x y z) | _ -> None [] @@ -130,13 +130,13 @@ module Option = [] let toArray option = match option with - | None -> [| |] + | None -> [||] | Some x -> [| x |] [] let toList option = match option with - | None -> [ ] + | None -> [] | Some x -> [ x ] [] @@ -146,7 +146,7 @@ module Option = | Some v -> System.Nullable(v) [] - let ofNullable (value:System.Nullable<'T>) = + let ofNullable (value: System.Nullable<'T>) = if value.HasValue then Some value.Value else @@ -215,13 +215,13 @@ module ValueOption = | ValueSome _ -> 1 [] - let fold<'T,'State> folder (state:'State) (voption: voption<'T>) = + let fold<'T, 'State> folder (state: 'State) (voption: voption<'T>) = match voption with | ValueNone -> state | ValueSome x -> folder state x [] - let foldBack<'T,'State> folder (voption: voption<'T>) (state:'State) = + let foldBack<'T, 'State> folder (voption: voption<'T>) (state: 'State) = match voption with | ValueNone -> state | ValueSome x -> folder x state @@ -254,18 +254,18 @@ module ValueOption = let map mapping voption = match voption with | ValueNone -> ValueNone - | ValueSome x -> ValueSome (mapping x) + | ValueSome x -> ValueSome(mapping x) [] - let map2 mapping voption1 voption2 = + let map2 mapping voption1 voption2 = match voption1, voption2 with - | ValueSome x, ValueSome y -> ValueSome (mapping x y) + | ValueSome x, ValueSome y -> ValueSome(mapping x y) | _ -> ValueNone [] - let map3 mapping voption1 voption2 voption3 = + let map3 mapping voption1 voption2 voption3 = match voption1, voption2, voption3 with - | ValueSome x, ValueSome y, ValueSome z -> ValueSome (mapping x y z) + | ValueSome x, ValueSome y, ValueSome z -> ValueSome(mapping x y z) | _ -> ValueNone [] @@ -284,18 +284,22 @@ module ValueOption = let filter predicate voption = match voption with | ValueNone -> ValueNone - | ValueSome x -> if predicate x then ValueSome x else ValueNone + | ValueSome x -> + if predicate x then + ValueSome x + else + ValueNone [] let toArray voption = match voption with - | ValueNone -> [| |] + | ValueNone -> [||] | ValueSome x -> [| x |] [] let toList voption = match voption with - | ValueNone -> [ ] + | ValueNone -> [] | ValueSome x -> [ x ] [] @@ -305,7 +309,7 @@ module ValueOption = | ValueSome v -> System.Nullable(v) [] - let ofNullable (value:System.Nullable<'T>) = + let ofNullable (value: System.Nullable<'T>) = if value.HasValue then ValueSome value.Value else diff --git a/src/FSharp.Core/quotations.fs b/src/FSharp.Core/quotations.fs index 3ef11b97bd3..a309d9c1816 100644 --- a/src/FSharp.Core/quotations.fs +++ b/src/FSharp.Core/quotations.fs @@ -28,29 +28,50 @@ module Helpers = let qOneOrMoreRLinear q inp = let rec queryAcc rvs e = match q e with - | Some(v, body) -> queryAcc (v :: rvs) body + | Some (v, body) -> queryAcc (v :: rvs) body | None -> match rvs with | [] -> None | _ -> Some(List.rev rvs, e) + queryAcc [] inp let qOneOrMoreLLinear q inp = let rec queryAcc e rvs = match q e with - | Some(body, v) -> queryAcc body (v :: rvs) + | Some (body, v) -> queryAcc body (v :: rvs) | None -> match rvs with | [] -> None | _ -> Some(e, rvs) + queryAcc inp [] - let mkRLinear mk (vs, body) = List.foldBack (fun v acc -> mk(v, acc)) vs body - let mkLLinear mk (body, vs) = List.fold (fun acc v -> mk(acc, v)) body vs + let mkRLinear mk (vs, body) = + List.foldBack (fun v acc -> mk (v, acc)) vs body + + let mkLLinear mk (body, vs) = + List.fold (fun acc v -> mk (acc, v)) body vs + + let staticBindingFlags = + BindingFlags.Static + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.DeclaredOnly + + let staticOrInstanceBindingFlags = + BindingFlags.Instance + ||| BindingFlags.Static + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.DeclaredOnly + + let instanceBindingFlags = + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.DeclaredOnly - let staticBindingFlags = BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly - let staticOrInstanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly - let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly let publicOrPrivateBindingFlags = BindingFlags.Public ||| BindingFlags.NonPublic let isDelegateType (typ: Type) = @@ -62,20 +83,21 @@ module Helpers = false let getDelegateInvoke ty = - if not (isDelegateType ty) then invalidArg "ty" (SR.GetString(SR.delegateExpected)) - ty.GetMethod("Invoke", instanceBindingFlags) + if not (isDelegateType ty) then + invalidArg "ty" (SR.GetString(SR.delegateExpected)) + ty.GetMethod("Invoke", instanceBindingFlags) let inline checkNonNull argName (v: 'T) = match box v with | null -> nullArg argName | _ -> () - let getTypesFromParamInfos (infos : ParameterInfo[]) = infos |> Array.map (fun pi -> pi.ParameterType) + let getTypesFromParamInfos (infos: ParameterInfo[]) = + infos |> Array.map (fun pi -> pi.ParameterType) open Helpers - [] [] type Var(name: string, typ: Type, ?isMutable: bool) = @@ -85,7 +107,7 @@ type Var(name: string, typ: Type, ?isMutable: bool) = let mutable lastStamp = -1L // first value retrieved will be 0 fun () -> System.Threading.Interlocked.Increment &lastStamp - static let globals = new Dictionary<(string*Type), Var>(11) + static let globals = new Dictionary<(string * Type), Var>(11) let stamp = getStamp () let isMutable = defaultArg isMutable false @@ -101,84 +123,102 @@ type Var(name: string, typ: Type, ?isMutable: bool) = static member Global(name, typ: Type) = checkNonNull "name" name checkNonNull "typ" typ + lock globals (fun () -> let mutable res = Unchecked.defaultof let ok = globals.TryGetValue((name, typ), &res) - if ok then res else - let res = new Var(name, typ) - globals.[(name, typ)] <- res - res) - override _.ToString() = name + if ok then + res + else + let res = new Var(name, typ) + globals.[(name, typ)] <- res + res) - override _.GetHashCode() = base.GetHashCode() + override _.ToString() = + name - override v.Equals(obj:obj) = + override _.GetHashCode() = + base.GetHashCode() + + override v.Equals(obj: obj) = match obj with | :? Var as v2 -> System.Object.ReferenceEquals(v, v2) | _ -> false interface System.IComparable with - member v.CompareTo(obj:obj) = + member v.CompareTo(obj: obj) = match obj with | :? Var as v2 -> - if System.Object.ReferenceEquals(v, v2) then 0 else - let c = compare v.Name v2.Name - if c <> 0 then c else - let c = compare v.Type.MetadataToken v2.Type.MetadataToken - if c <> 0 then c else - let c = compare v.Type.Module.MetadataToken v2.Type.Module.MetadataToken - if c <> 0 then c else - let c = compare v.Type.Assembly.FullName v2.Type.Assembly.FullName - if c <> 0 then c else - compare v.Stamp v2.Stamp + if System.Object.ReferenceEquals(v, v2) then + 0 + else + let c = compare v.Name v2.Name + + if c <> 0 then + c + else + let c = compare v.Type.MetadataToken v2.Type.MetadataToken + + if c <> 0 then + c + else + let c = compare v.Type.Module.MetadataToken v2.Type.Module.MetadataToken + + if c <> 0 then + c + else + let c = compare v.Type.Assembly.FullName v2.Type.Assembly.FullName + + if c <> 0 then + c + else + compare v.Stamp v2.Stamp | _ -> 0 /// Represents specifications of a subset of F# expressions [] type Tree = - | CombTerm of ExprConstInfo * Expr list - | VarTerm of Var + | CombTerm of ExprConstInfo * Expr list + | VarTerm of Var | LambdaTerm of Var * Expr - | HoleTerm of Type * int + | HoleTerm of Type * int -and - [] - ExprConstInfo = +and [] ExprConstInfo = | AppOp | IfThenElseOp | LetRecOp | LetRecCombOp | LetOp - | NewRecordOp of Type - | NewUnionCaseOp of UnionCaseInfo - | UnionCaseTestOp of UnionCaseInfo - | NewTupleOp of Type - | TupleGetOp of Type * int - | InstancePropGetOp of PropertyInfo - | StaticPropGetOp of PropertyInfo - | InstancePropSetOp of PropertyInfo - | StaticPropSetOp of PropertyInfo - | InstanceFieldGetOp of FieldInfo - | StaticFieldGetOp of FieldInfo - | InstanceFieldSetOp of FieldInfo - | StaticFieldSetOp of FieldInfo - | NewObjectOp of ConstructorInfo + | NewRecordOp of Type + | NewUnionCaseOp of UnionCaseInfo + | UnionCaseTestOp of UnionCaseInfo + | NewTupleOp of Type + | TupleGetOp of Type * int + | InstancePropGetOp of PropertyInfo + | StaticPropGetOp of PropertyInfo + | InstancePropSetOp of PropertyInfo + | StaticPropSetOp of PropertyInfo + | InstanceFieldGetOp of FieldInfo + | StaticFieldGetOp of FieldInfo + | InstanceFieldSetOp of FieldInfo + | StaticFieldSetOp of FieldInfo + | NewObjectOp of ConstructorInfo | InstanceMethodCallOp of MethodInfo | StaticMethodCallOp of MethodInfo /// A new Call node type in F# 5.0, storing extra information about witnesses | InstanceMethodCallWOp of MethodInfo * MethodInfo * int /// A new Call node type in F# 5.0, storing extra information about witnesses | StaticMethodCallWOp of MethodInfo * MethodInfo * int - | CoerceOp of Type - | NewArrayOp of Type - | NewDelegateOp of Type + | CoerceOp of Type + | NewArrayOp of Type + | NewDelegateOp of Type | QuoteOp of bool | SequentialOp | AddressOfOp | VarSetOp | AddressSetOp - | TypeTestOp of Type + | TypeTestOp of Type | TryWithOp | TryFinallyOp | ForIntegerRangeLoopOp @@ -188,8 +228,7 @@ and | WithValueOp of obj * Type | DefaultValueOp of Type -and [] - Expr(term:Tree, attribs: Expr list) = +and [] Expr(term: Tree, attribs: Expr list) = member x.Tree = term member x.CustomAttributes = attribs @@ -199,43 +238,51 @@ and [] let rec eq t1 t2 = match t1, t2 with // We special-case ValueOp to ensure that ValueWithName = Value - | CombTerm(ValueOp(v1, ty1, _), []), CombTerm(ValueOp(v2, ty2, _), []) -> (v1 = v2) && (ty1 = ty2) + | CombTerm (ValueOp (v1, ty1, _), []), CombTerm (ValueOp (v2, ty2, _), []) -> (v1 = v2) && (ty1 = ty2) // We strip off InstanceMethodCallWOp to ensure that CallWithWitness = Call - | CombTerm(InstanceMethodCallWOp(minfo1, _minfoW1, nWitnesses1), obj1::args1WithoutObj), _ -> + | CombTerm (InstanceMethodCallWOp (minfo1, _minfoW1, nWitnesses1), obj1 :: args1WithoutObj), _ -> if nWitnesses1 <= args1WithoutObj.Length then let args1WithoutWitnesses = List.skip nWitnesses1 args1WithoutObj - eq (CombTerm(InstanceMethodCallOp(minfo1), obj1::args1WithoutWitnesses)) t2 - else + eq (CombTerm(InstanceMethodCallOp(minfo1), obj1 :: args1WithoutWitnesses)) t2 + else false // We strip off InstanceMethodCallWOp to ensure that CallWithWitness = Call - | _, CombTerm(InstanceMethodCallWOp(minfo2, _minfoW2, nWitnesses2), obj2::args2WithoutObj) when nWitnesses2 <= args2WithoutObj.Length -> + | _, CombTerm (InstanceMethodCallWOp (minfo2, _minfoW2, nWitnesses2), obj2 :: args2WithoutObj) when + nWitnesses2 <= args2WithoutObj.Length + -> let args2WithoutWitnesses = List.skip nWitnesses2 args2WithoutObj - eq t1 (CombTerm(InstanceMethodCallOp(minfo2), obj2::args2WithoutWitnesses)) + eq t1 (CombTerm(InstanceMethodCallOp(minfo2), obj2 :: args2WithoutWitnesses)) // We strip off StaticMethodCallWOp to ensure that CallWithWitness = Call - | CombTerm(StaticMethodCallWOp(minfo1, _minfoW1, nWitnesses1), args1), _ when nWitnesses1 <= args1.Length -> + | CombTerm (StaticMethodCallWOp (minfo1, _minfoW1, nWitnesses1), args1), _ when + nWitnesses1 <= args1.Length + -> let argsWithoutWitnesses1 = List.skip nWitnesses1 args1 eq (CombTerm(StaticMethodCallOp(minfo1), argsWithoutWitnesses1)) t2 // We strip off StaticMethodCallWOp to ensure that CallWithWitness = Call - | _, CombTerm(StaticMethodCallWOp(minfo2, _minfoW2, nWitnesses2), args2) when nWitnesses2 <= args2.Length -> + | _, CombTerm (StaticMethodCallWOp (minfo2, _minfoW2, nWitnesses2), args2) when + nWitnesses2 <= args2.Length + -> let argsWithoutWitnesses2 = List.skip nWitnesses2 args2 eq t1 (CombTerm(StaticMethodCallOp(minfo2), argsWithoutWitnesses2)) - | CombTerm(c1, es1), CombTerm(c2, es2) -> c1 = c2 && es1.Length = es2.Length && (es1 = es2) + | CombTerm (c1, es1), CombTerm (c2, es2) -> c1 = c2 && es1.Length = es2.Length && (es1 = es2) | VarTerm v1, VarTerm v2 -> (v1 = v2) - | LambdaTerm (v1, e1), LambdaTerm(v2, e2) -> (v1 = v2) && (e1 = e2) - | HoleTerm (ty1, n1), HoleTerm(ty2, n2) -> (ty1 = ty2) && (n1 = n2) + | LambdaTerm (v1, e1), LambdaTerm (v2, e2) -> (v1 = v2) && (e1 = e2) + | HoleTerm (ty1, n1), HoleTerm (ty2, n2) -> (ty1 = ty2) && (n1 = n2) | _ -> false + eq x.Tree y.Tree | _ -> false override x.GetHashCode() = x.Tree.GetHashCode() - override x.ToString() = x.ToString false + override x.ToString() = + x.ToString false member x.ToString full = Display.layout_to_string FormatOptions.Default (x.GetLayout(full)) @@ -243,101 +290,163 @@ and [] member x.DebugText = x.ToString(false) member x.GetLayout long = - let expr (e: Expr ) = e.GetLayout long - let exprs (es: Expr list) = es |> List.map expr - let parens ls = bracketL (commaListL ls) - let pairL l1 l2 = bracketL (l1 ^^ sepL comma ^^ l2) - let listL ls = squareBracketL (commaListL ls) - let combTaggedL nm ls = wordL nm ^^ parens ls - let combL nm ls = combTaggedL (tagKeyword nm) ls + let expr (e: Expr) = + e.GetLayout long + + let exprs (es: Expr list) = + es |> List.map expr + + let parens ls = + bracketL (commaListL ls) + + let pairL l1 l2 = + bracketL (l1 ^^ sepL comma ^^ l2) + + let listL ls = + squareBracketL (commaListL ls) + + let combTaggedL nm ls = + wordL nm ^^ parens ls + + let combL nm ls = + combTaggedL (tagKeyword nm) ls + let noneL = wordL (tagProperty "None") - let someL e = combTaggedL (tagMethod "Some") [expr e] - let typeL (o: Type) = wordL (tagClass (if long then o.FullName else o.Name)) - let objL (o: 'T) = wordL (tagText (sprintf "%A" o)) - let varL (v: Var) = wordL (tagLocal v.Name) - let (|E|) (e: Expr) = e.Tree - let (|Lambda|_|) (E x) = match x with LambdaTerm(a, b) -> Some (a, b) | _ -> None - let (|IteratedLambda|_|) (e: Expr) = qOneOrMoreRLinear (|Lambda|_|) e - let ucaseL (unionCase:UnionCaseInfo) = (if long then objL unionCase else wordL (tagUnionCase unionCase.Name)) - let minfoL (minfo: MethodInfo) = if long then objL minfo else wordL (tagMethod minfo.Name) - let cinfoL (cinfo: ConstructorInfo) = if long then objL cinfo else wordL (tagMethod cinfo.DeclaringType.Name) - let pinfoL (pinfo: PropertyInfo) = if long then objL pinfo else wordL (tagProperty pinfo.Name) - let finfoL (finfo: FieldInfo) = if long then objL finfo else wordL (tagField finfo.Name) + + let someL e = + combTaggedL (tagMethod "Some") [ expr e ] + + let typeL (o: Type) = + wordL (tagClass (if long then o.FullName else o.Name)) + + let objL (o: 'T) = + wordL (tagText (sprintf "%A" o)) + + let varL (v: Var) = + wordL (tagLocal v.Name) + + let (|E|) (e: Expr) = + e.Tree + + let (|Lambda|_|) (E x) = + match x with + | LambdaTerm (a, b) -> Some(a, b) + | _ -> None + + let (|IteratedLambda|_|) (e: Expr) = + qOneOrMoreRLinear (|Lambda|_|) e + + let ucaseL (unionCase: UnionCaseInfo) = + (if long then + objL unionCase + else + wordL (tagUnionCase unionCase.Name)) + + let minfoL (minfo: MethodInfo) = + if long then + objL minfo + else + wordL (tagMethod minfo.Name) + + let cinfoL (cinfo: ConstructorInfo) = + if long then + objL cinfo + else + wordL (tagMethod cinfo.DeclaringType.Name) + + let pinfoL (pinfo: PropertyInfo) = + if long then + objL pinfo + else + wordL (tagProperty pinfo.Name) + + let finfoL (finfo: FieldInfo) = + if long then + objL finfo + else + wordL (tagField finfo.Name) + let rec (|NLambdas|_|) n (e: Expr) = match e with | _ when n <= 0 -> Some([], e) - | Lambda(v, NLambdas ((-) n 1) (vs, b)) -> Some(v :: vs, b) + | Lambda (v, NLambdas ((-) n 1) (vs, b)) -> Some(v :: vs, b) | _ -> None match x.Tree with - | CombTerm(AppOp, args) -> combL "Application" (exprs args) - | CombTerm(IfThenElseOp, args) -> combL "IfThenElse" (exprs args) - | CombTerm(LetRecOp, [IteratedLambda(vs, E(CombTerm(LetRecCombOp, b2 :: bs)))]) -> combL "LetRecursive" [listL (List.map2 pairL (List.map varL vs) (exprs bs) ); b2.GetLayout long] - | CombTerm(LetOp, [e;E(LambdaTerm(v, b))]) -> combL "Let" [varL v; e.GetLayout long; b.GetLayout long] - | CombTerm(NewRecordOp ty, args) -> combL "NewRecord" (typeL ty :: exprs args) - | CombTerm(NewUnionCaseOp unionCase, args) -> combL "NewUnionCase" (ucaseL unionCase :: exprs args) - | CombTerm(UnionCaseTestOp unionCase, args) -> combL "UnionCaseTest" (exprs args@ [ucaseL unionCase]) - | CombTerm(NewTupleOp _, args) -> combL "NewTuple" (exprs args) - | CombTerm(TupleGetOp (_, i), [arg]) -> combL "TupleGet" ([expr arg] @ [objL i]) - | CombTerm(ValueOp(v, _, Some nm), []) -> combL "ValueWithName" [objL v; wordL (tagLocal nm)] - | CombTerm(ValueOp(v, _, None), []) -> combL "Value" [objL v] - | CombTerm(WithValueOp(v, _), [defn]) -> combL "WithValue" [objL v; expr defn] - - | CombTerm(InstanceMethodCallOp(minfo), obj::args) -> - combL "Call" [someL obj; minfoL minfo; listL (exprs args)] - - | CombTerm(StaticMethodCallOp(minfo), args) -> - combL "Call" [noneL; minfoL minfo; listL (exprs args)] - - | CombTerm(InstanceMethodCallWOp(minfo, _minfoW, nWitnesses), obj::argsWithoutObj) when nWitnesses <= argsWithoutObj.Length -> + | CombTerm (AppOp, args) -> combL "Application" (exprs args) + | CombTerm (IfThenElseOp, args) -> combL "IfThenElse" (exprs args) + | CombTerm (LetRecOp, [ IteratedLambda (vs, E (CombTerm (LetRecCombOp, b2 :: bs))) ]) -> + combL "LetRecursive" [ listL (List.map2 pairL (List.map varL vs) (exprs bs)); b2.GetLayout long ] + | CombTerm (LetOp, [ e; E (LambdaTerm (v, b)) ]) -> combL "Let" [ varL v; e.GetLayout long; b.GetLayout long ] + | CombTerm (NewRecordOp ty, args) -> combL "NewRecord" (typeL ty :: exprs args) + | CombTerm (NewUnionCaseOp unionCase, args) -> combL "NewUnionCase" (ucaseL unionCase :: exprs args) + | CombTerm (UnionCaseTestOp unionCase, args) -> combL "UnionCaseTest" (exprs args @ [ ucaseL unionCase ]) + | CombTerm (NewTupleOp _, args) -> combL "NewTuple" (exprs args) + | CombTerm (TupleGetOp (_, i), [ arg ]) -> combL "TupleGet" ([ expr arg ] @ [ objL i ]) + | CombTerm (ValueOp (v, _, Some nm), []) -> combL "ValueWithName" [ objL v; wordL (tagLocal nm) ] + | CombTerm (ValueOp (v, _, None), []) -> combL "Value" [ objL v ] + | CombTerm (WithValueOp (v, _), [ defn ]) -> combL "WithValue" [ objL v; expr defn ] + + | CombTerm (InstanceMethodCallOp (minfo), obj :: args) -> + combL "Call" [ someL obj; minfoL minfo; listL (exprs args) ] + + | CombTerm (StaticMethodCallOp (minfo), args) -> combL "Call" [ noneL; minfoL minfo; listL (exprs args) ] + + | CombTerm (InstanceMethodCallWOp (minfo, _minfoW, nWitnesses), obj :: argsWithoutObj) when + nWitnesses <= argsWithoutObj.Length + -> let argsWithoutWitnesses = List.skip nWitnesses argsWithoutObj - combL "Call" [someL obj; minfoL minfo; listL (exprs argsWithoutWitnesses)] + combL "Call" [ someL obj; minfoL minfo; listL (exprs argsWithoutWitnesses) ] - | CombTerm(StaticMethodCallWOp(minfo, _minfoW, nWitnesses), args) when nWitnesses <= args.Length -> + | CombTerm (StaticMethodCallWOp (minfo, _minfoW, nWitnesses), args) when nWitnesses <= args.Length -> let argsWithoutWitnesses = List.skip nWitnesses args - combL "Call" [noneL; minfoL minfo; listL (exprs argsWithoutWitnesses)] - - | CombTerm(InstancePropGetOp(pinfo), (obj::args)) -> combL "PropertyGet" [someL obj; pinfoL pinfo; listL (exprs args)] - | CombTerm(StaticPropGetOp(pinfo), args) -> combL "PropertyGet" [noneL; pinfoL pinfo; listL (exprs args)] - | CombTerm(InstancePropSetOp(pinfo), (obj::args)) -> combL "PropertySet" [someL obj; pinfoL pinfo; listL (exprs args)] - | CombTerm(StaticPropSetOp(pinfo), args) -> combL "PropertySet" [noneL; pinfoL pinfo; listL (exprs args)] - | CombTerm(InstanceFieldGetOp(finfo), [obj]) -> combL "FieldGet" [someL obj; finfoL finfo] - | CombTerm(StaticFieldGetOp(finfo), []) -> combL "FieldGet" [noneL; finfoL finfo] - | CombTerm(InstanceFieldSetOp(finfo), [obj;v]) -> combL "FieldSet" [someL obj; finfoL finfo; expr v;] - | CombTerm(StaticFieldSetOp(finfo), [v]) -> combL "FieldSet" [noneL; finfoL finfo; expr v;] - | CombTerm(CoerceOp(ty), [arg]) -> combL "Coerce" [ expr arg; typeL ty] - | CombTerm(NewObjectOp cinfo, args) -> combL "NewObject" ([ cinfoL cinfo ] @ exprs args) - | CombTerm(DefaultValueOp ty, args) -> combL "DefaultValue" ([ typeL ty ] @ exprs args) - | CombTerm(NewArrayOp ty, args) -> combL "NewArray" ([ typeL ty ] @ exprs args) - | CombTerm(TypeTestOp ty, args) -> combL "TypeTest" ([ typeL ty] @ exprs args) - | CombTerm(AddressOfOp, args) -> combL "AddressOf" (exprs args) - | CombTerm(VarSetOp, [E(VarTerm v); e]) -> combL "VarSet" [varL v; expr e] - | CombTerm(AddressSetOp, args) -> combL "AddressSet" (exprs args) - | CombTerm(ForIntegerRangeLoopOp, [e1;e2;E(LambdaTerm(v, e3))]) -> combL "ForIntegerRangeLoop" [varL v; expr e1; expr e2; expr e3] - | CombTerm(WhileLoopOp, args) -> combL "WhileLoop" (exprs args) - | CombTerm(TryFinallyOp, args) -> combL "TryFinally" (exprs args) - | CombTerm(TryWithOp, [e1;Lambda(v1, e2);Lambda(v2, e3)]) -> combL "TryWith" [expr e1; varL v1; expr e2; varL v2; expr e3] - | CombTerm(SequentialOp, args) -> combL "Sequential" (exprs args) - - | CombTerm(NewDelegateOp ty, [e]) -> + combL "Call" [ noneL; minfoL minfo; listL (exprs argsWithoutWitnesses) ] + + | CombTerm (InstancePropGetOp (pinfo), (obj :: args)) -> + combL "PropertyGet" [ someL obj; pinfoL pinfo; listL (exprs args) ] + | CombTerm (StaticPropGetOp (pinfo), args) -> combL "PropertyGet" [ noneL; pinfoL pinfo; listL (exprs args) ] + | CombTerm (InstancePropSetOp (pinfo), (obj :: args)) -> + combL "PropertySet" [ someL obj; pinfoL pinfo; listL (exprs args) ] + | CombTerm (StaticPropSetOp (pinfo), args) -> combL "PropertySet" [ noneL; pinfoL pinfo; listL (exprs args) ] + | CombTerm (InstanceFieldGetOp (finfo), [ obj ]) -> combL "FieldGet" [ someL obj; finfoL finfo ] + | CombTerm (StaticFieldGetOp (finfo), []) -> combL "FieldGet" [ noneL; finfoL finfo ] + | CombTerm (InstanceFieldSetOp (finfo), [ obj; v ]) -> combL "FieldSet" [ someL obj; finfoL finfo; expr v ] + | CombTerm (StaticFieldSetOp (finfo), [ v ]) -> combL "FieldSet" [ noneL; finfoL finfo; expr v ] + | CombTerm (CoerceOp (ty), [ arg ]) -> combL "Coerce" [ expr arg; typeL ty ] + | CombTerm (NewObjectOp cinfo, args) -> combL "NewObject" ([ cinfoL cinfo ] @ exprs args) + | CombTerm (DefaultValueOp ty, args) -> combL "DefaultValue" ([ typeL ty ] @ exprs args) + | CombTerm (NewArrayOp ty, args) -> combL "NewArray" ([ typeL ty ] @ exprs args) + | CombTerm (TypeTestOp ty, args) -> combL "TypeTest" ([ typeL ty ] @ exprs args) + | CombTerm (AddressOfOp, args) -> combL "AddressOf" (exprs args) + | CombTerm (VarSetOp, [ E (VarTerm v); e ]) -> combL "VarSet" [ varL v; expr e ] + | CombTerm (AddressSetOp, args) -> combL "AddressSet" (exprs args) + | CombTerm (ForIntegerRangeLoopOp, [ e1; e2; E (LambdaTerm (v, e3)) ]) -> + combL "ForIntegerRangeLoop" [ varL v; expr e1; expr e2; expr e3 ] + | CombTerm (WhileLoopOp, args) -> combL "WhileLoop" (exprs args) + | CombTerm (TryFinallyOp, args) -> combL "TryFinally" (exprs args) + | CombTerm (TryWithOp, [ e1; Lambda (v1, e2); Lambda (v2, e3) ]) -> + combL "TryWith" [ expr e1; varL v1; expr e2; varL v2; expr e3 ] + | CombTerm (SequentialOp, args) -> combL "Sequential" (exprs args) + + | CombTerm (NewDelegateOp ty, [ e ]) -> let nargs = (getDelegateInvoke ty).GetParameters().Length + if nargs = 0 then match e with - | NLambdas 1 ([_], e) -> combL "NewDelegate" ([typeL ty] @ [expr e]) - | NLambdas 0 ([], e) -> combL "NewDelegate" ([typeL ty] @ [expr e]) - | _ -> combL "NewDelegate" [typeL ty; expr e] + | NLambdas 1 ([ _ ], e) -> combL "NewDelegate" ([ typeL ty ] @ [ expr e ]) + | NLambdas 0 ([], e) -> combL "NewDelegate" ([ typeL ty ] @ [ expr e ]) + | _ -> combL "NewDelegate" [ typeL ty; expr e ] else match e with - | NLambdas nargs (vs, e) -> combL "NewDelegate" ([typeL ty] @ (vs |> List.map varL) @ [expr e]) - | _ -> combL "NewDelegate" [typeL ty; expr e] + | NLambdas nargs (vs, e) -> combL "NewDelegate" ([ typeL ty ] @ (vs |> List.map varL) @ [ expr e ]) + | _ -> combL "NewDelegate" [ typeL ty; expr e ] | VarTerm v -> wordL (tagLocal v.Name) - | LambdaTerm(v, b) -> combL "Lambda" [varL v; expr b] + | LambdaTerm (v, b) -> combL "Lambda" [ varL v; expr b ] | HoleTerm _ -> wordL (tagLocal "_") - | CombTerm(QuoteOp _, args) -> combL "Quote" (exprs args) + | CombTerm (QuoteOp _, args) -> combL "Quote" (exprs args) | _ -> failwithf "Unexpected term" -and [] - Expr<'T>(term:Tree, attribs) = +and [] Expr<'T>(term: Tree, attribs) = inherit Expr(term, attribs) member x.Raw = (x :> Expr) @@ -348,20 +457,24 @@ module Patterns = /// as a computation. type Instantiable<'T> = (int -> Type) -> 'T - type ByteStream(bytes:byte[], initial: int, len: int) = + type ByteStream(bytes: byte[], initial: int, len: int) = let mutable pos = initial let lim = initial + len member b.ReadByte() = - if pos >= lim then failwith "end of stream" + if pos >= lim then + failwith "end of stream" + let res = int32 bytes.[pos] pos <- pos + 1 res member b.ReadBytes n = - if pos + n > lim then failwith "ByteStream.ReadBytes: end of stream" - let res = bytes.[pos..pos+n-1] + if pos + n > lim then + failwith "ByteStream.ReadBytes: end of stream" + + let res = bytes.[pos .. pos + n - 1] pos <- pos + n res @@ -370,217 +483,319 @@ module Patterns = pos <- pos + n res + let E t = + new Expr(t, []) - let E t = new Expr< >(t, []) - let EA (t, attribs) = new Expr< >(t, attribs) - let ES ts = List.map E ts + let EA (t, attribs) = + new Expr(t, attribs) - let (|E|) (e: Expr) = e.Tree - let (|ES|) (es: Expr list) = es |> List.map (fun e -> e.Tree) - let (|FrontAndBack|_|) es = - let rec loop acc xs = match xs with [] -> None | [h] -> Some (List.rev acc, h) | h :: t -> loop (h :: acc) t - loop [] es + let ES ts = + List.map E ts + + let (|E|) (e: Expr) = + e.Tree + let (|ES|) (es: Expr list) = + es |> List.map (fun e -> e.Tree) + + let (|FrontAndBack|_|) es = + let rec loop acc xs = + match xs with + | [] -> None + | [ h ] -> Some(List.rev acc, h) + | h :: t -> loop (h :: acc) t + loop [] es - let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition() + let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition () let exprTyC = typedefof> let voidTy = typeof let unitTy = typeof - let removeVoid a = if a = voidTy then unitTy else a - let addVoid a = if a = unitTy then voidTy else a + + let removeVoid a = + if a = voidTy then unitTy else a + + let addVoid a = + if a = unitTy then voidTy else a + let mkFunTy a b = let (a, b) = removeVoid a, removeVoid b - funTyC.MakeGenericType([| a;b |]) + funTyC.MakeGenericType([| a; b |]) - let mkArrayTy (t: Type) = t.MakeArrayType() - let mkExprTy (t: Type) = exprTyC.MakeGenericType([| t |]) - let rawExprTy = typeof + let mkArrayTy (t: Type) = + t.MakeArrayType() + let mkExprTy (t: Type) = + exprTyC.MakeGenericType([| t |]) + + let rawExprTy = typeof //-------------------------------------------------------------------------- // Active patterns for decomposing quotations //-------------------------------------------------------------------------- - let (|Comb0|_|) (E x) = match x with CombTerm(k, []) -> Some k | _ -> None + let (|Comb0|_|) (E x) = + match x with + | CombTerm (k, []) -> Some k + | _ -> None - let (|Comb1|_|) (E x) = match x with CombTerm(k, [x]) -> Some(k, x) | _ -> None + let (|Comb1|_|) (E x) = + match x with + | CombTerm (k, [ x ]) -> Some(k, x) + | _ -> None - let (|Comb2|_|) (E x) = match x with CombTerm(k, [x1;x2]) -> Some(k, x1, x2) | _ -> None + let (|Comb2|_|) (E x) = + match x with + | CombTerm (k, [ x1; x2 ]) -> Some(k, x1, x2) + | _ -> None - let (|Comb3|_|) (E x) = match x with CombTerm(k, [x1;x2;x3]) -> Some(k, x1, x2, x3) | _ -> None + let (|Comb3|_|) (E x) = + match x with + | CombTerm (k, [ x1; x2; x3 ]) -> Some(k, x1, x2, x3) + | _ -> None [] - let (|Var|_|) (E x) = match x with VarTerm v -> Some v | _ -> None + let (|Var|_|) (E x) = + match x with + | VarTerm v -> Some v + | _ -> None [] - let (|Application|_|) input = match input with Comb2(AppOp, a, b) -> Some (a, b) | _ -> None + let (|Application|_|) input = + match input with + | Comb2 (AppOp, a, b) -> Some(a, b) + | _ -> None [] - let (|Lambda|_|) (E x) = match x with LambdaTerm(a, b) -> Some (a, b) | _ -> None + let (|Lambda|_|) (E x) = + match x with + | LambdaTerm (a, b) -> Some(a, b) + | _ -> None [] - let (|Quote|_|) (E x) = match x with CombTerm(QuoteOp _, [a]) -> Some (a) | _ -> None + let (|Quote|_|) (E x) = + match x with + | CombTerm (QuoteOp _, [ a ]) -> Some(a) + | _ -> None [] - let (|QuoteRaw|_|) (E x) = match x with CombTerm(QuoteOp false, [a]) -> Some (a) | _ -> None + let (|QuoteRaw|_|) (E x) = + match x with + | CombTerm (QuoteOp false, [ a ]) -> Some(a) + | _ -> None [] - let (|QuoteTyped|_|) (E x) = match x with CombTerm(QuoteOp true, [a]) -> Some (a) | _ -> None + let (|QuoteTyped|_|) (E x) = + match x with + | CombTerm (QuoteOp true, [ a ]) -> Some(a) + | _ -> None [] - let (|IfThenElse|_|) input = match input with Comb3(IfThenElseOp, e1, e2, e3) -> Some(e1, e2, e3) | _ -> None + let (|IfThenElse|_|) input = + match input with + | Comb3 (IfThenElseOp, e1, e2, e3) -> Some(e1, e2, e3) + | _ -> None [] - let (|NewTuple|_|) input = match input with E(CombTerm(NewTupleOp(_), es)) -> Some es | _ -> None + let (|NewTuple|_|) input = + match input with + | E (CombTerm (NewTupleOp (_), es)) -> Some es + | _ -> None [] - let (|NewStructTuple|_|) input = match input with E(CombTerm(NewTupleOp(ty), es)) when ty.IsValueType -> Some es | _ -> None + let (|NewStructTuple|_|) input = + match input with + | E (CombTerm (NewTupleOp (ty), es)) when ty.IsValueType -> Some es + | _ -> None [] - let (|DefaultValue|_|) input = match input with E(CombTerm(DefaultValueOp ty, [])) -> Some ty | _ -> None + let (|DefaultValue|_|) input = + match input with + | E (CombTerm (DefaultValueOp ty, [])) -> Some ty + | _ -> None [] - let (|NewRecord|_|) input = match input with E(CombTerm(NewRecordOp x, es)) -> Some(x, es) | _ -> None + let (|NewRecord|_|) input = + match input with + | E (CombTerm (NewRecordOp x, es)) -> Some(x, es) + | _ -> None [] - let (|NewUnionCase|_|) input = match input with E(CombTerm(NewUnionCaseOp unionCase, es)) -> Some(unionCase, es) | _ -> None + let (|NewUnionCase|_|) input = + match input with + | E (CombTerm (NewUnionCaseOp unionCase, es)) -> Some(unionCase, es) + | _ -> None [] - let (|UnionCaseTest|_|) input = match input with Comb1(UnionCaseTestOp unionCase, e) -> Some(e, unionCase) | _ -> None + let (|UnionCaseTest|_|) input = + match input with + | Comb1 (UnionCaseTestOp unionCase, e) -> Some(e, unionCase) + | _ -> None [] - let (|TupleGet|_|) input = match input with Comb1(TupleGetOp(_, n), e) -> Some(e, n) | _ -> None + let (|TupleGet|_|) input = + match input with + | Comb1 (TupleGetOp (_, n), e) -> Some(e, n) + | _ -> None [] - let (|Coerce|_|) input = match input with Comb1(CoerceOp ty, e1) -> Some(e1, ty) | _ -> None + let (|Coerce|_|) input = + match input with + | Comb1 (CoerceOp ty, e1) -> Some(e1, ty) + | _ -> None [] - let (|TypeTest|_|) input = match input with Comb1(TypeTestOp ty, e1) -> Some(e1, ty) | _ -> None + let (|TypeTest|_|) input = + match input with + | Comb1 (TypeTestOp ty, e1) -> Some(e1, ty) + | _ -> None [] - let (|NewArray|_|) input = match input with E(CombTerm(NewArrayOp ty, es)) -> Some(ty, es) | _ -> None + let (|NewArray|_|) input = + match input with + | E (CombTerm (NewArrayOp ty, es)) -> Some(ty, es) + | _ -> None [] - let (|AddressSet|_|) input = match input with E(CombTerm(AddressSetOp, [e;v])) -> Some(e, v) | _ -> None + let (|AddressSet|_|) input = + match input with + | E (CombTerm (AddressSetOp, [ e; v ])) -> Some(e, v) + | _ -> None [] - let (|TryFinally|_|) input = match input with E(CombTerm(TryFinallyOp, [e1;e2])) -> Some(e1, e2) | _ -> None + let (|TryFinally|_|) input = + match input with + | E (CombTerm (TryFinallyOp, [ e1; e2 ])) -> Some(e1, e2) + | _ -> None [] - let (|TryWith|_|) input = match input with E(CombTerm(TryWithOp, [e1;Lambda(v1, e2);Lambda(v2, e3)])) -> Some(e1, v1, e2, v2, e3) | _ -> None + let (|TryWith|_|) input = + match input with + | E (CombTerm (TryWithOp, [ e1; Lambda (v1, e2); Lambda (v2, e3) ])) -> Some(e1, v1, e2, v2, e3) + | _ -> None [] - let (|VarSet|_| ) input = match input with E(CombTerm(VarSetOp, [E(VarTerm v); e])) -> Some(v, e) | _ -> None + let (|VarSet|_|) input = + match input with + | E (CombTerm (VarSetOp, [ E (VarTerm v); e ])) -> Some(v, e) + | _ -> None [] - let (|Value|_|) input = match input with E(CombTerm(ValueOp (v, ty, _), _)) -> Some(v, ty) | _ -> None + let (|Value|_|) input = + match input with + | E (CombTerm (ValueOp (v, ty, _), _)) -> Some(v, ty) + | _ -> None [] - let (|ValueObj|_|) input = match input with E(CombTerm(ValueOp (v, _, _), _)) -> Some v | _ -> None + let (|ValueObj|_|) input = + match input with + | E (CombTerm (ValueOp (v, _, _), _)) -> Some v + | _ -> None [] let (|ValueWithName|_|) input = match input with - | E(CombTerm(ValueOp (v, ty, Some nm), _)) -> Some(v, ty, nm) + | E (CombTerm (ValueOp (v, ty, Some nm), _)) -> Some(v, ty, nm) | _ -> None [] let (|WithValue|_|) input = match input with - | E(CombTerm(WithValueOp (v, ty), [e])) -> Some(v, ty, e) + | E (CombTerm (WithValueOp (v, ty), [ e ])) -> Some(v, ty, e) | _ -> None [] let (|AddressOf|_|) input = match input with - | Comb1(AddressOfOp, e) -> Some e + | Comb1 (AddressOfOp, e) -> Some e | _ -> None [] let (|Sequential|_|) input = match input with - | Comb2(SequentialOp, e1, e2) -> Some(e1, e2) + | Comb2 (SequentialOp, e1, e2) -> Some(e1, e2) | _ -> None [] let (|ForIntegerRangeLoop|_|) input = match input with - | Comb3(ForIntegerRangeLoopOp, e1, e2, Lambda(v, e3)) -> Some(v, e1, e2, e3) + | Comb3 (ForIntegerRangeLoopOp, e1, e2, Lambda (v, e3)) -> Some(v, e1, e2, e3) | _ -> None [] let (|WhileLoop|_|) input = match input with - | Comb2(WhileLoopOp, e1, e2) -> Some(e1, e2) + | Comb2 (WhileLoopOp, e1, e2) -> Some(e1, e2) | _ -> None [] let (|PropertyGet|_|) input = match input with - | E(CombTerm(StaticPropGetOp pinfo, args)) -> Some(None, pinfo, args) - | E(CombTerm(InstancePropGetOp pinfo, obj :: args)) -> Some(Some obj, pinfo, args) + | E (CombTerm (StaticPropGetOp pinfo, args)) -> Some(None, pinfo, args) + | E (CombTerm (InstancePropGetOp pinfo, obj :: args)) -> Some(Some obj, pinfo, args) | _ -> None [] let (|PropertySet|_|) input = match input with - | E(CombTerm(StaticPropSetOp pinfo, FrontAndBack(args, v))) -> Some(None, pinfo, args, v) - | E(CombTerm(InstancePropSetOp pinfo, obj :: FrontAndBack(args, v))) -> Some(Some obj, pinfo, args, v) + | E (CombTerm (StaticPropSetOp pinfo, FrontAndBack (args, v))) -> Some(None, pinfo, args, v) + | E (CombTerm (InstancePropSetOp pinfo, obj :: FrontAndBack (args, v))) -> Some(Some obj, pinfo, args, v) | _ -> None - [] let (|FieldGet|_|) input = match input with - | E(CombTerm(StaticFieldGetOp finfo, [])) -> Some(None, finfo) - | E(CombTerm(InstanceFieldGetOp finfo, [obj])) -> Some(Some obj, finfo) + | E (CombTerm (StaticFieldGetOp finfo, [])) -> Some(None, finfo) + | E (CombTerm (InstanceFieldGetOp finfo, [ obj ])) -> Some(Some obj, finfo) | _ -> None [] let (|FieldSet|_|) input = match input with - | E(CombTerm(StaticFieldSetOp finfo, [v])) -> Some(None, finfo, v) - | E(CombTerm(InstanceFieldSetOp finfo, [obj;v])) -> Some(Some obj, finfo, v) + | E (CombTerm (StaticFieldSetOp finfo, [ v ])) -> Some(None, finfo, v) + | E (CombTerm (InstanceFieldSetOp finfo, [ obj; v ])) -> Some(Some obj, finfo, v) | _ -> None [] let (|NewObject|_|) input = match input with - | E(CombTerm(NewObjectOp ty, e)) -> Some(ty, e) | _ -> None + | E (CombTerm (NewObjectOp ty, e)) -> Some(ty, e) + | _ -> None [] let (|Call|_|) input = match input with - | E(CombTerm(StaticMethodCallOp minfo, args)) -> Some(None, minfo, args) + | E (CombTerm (StaticMethodCallOp minfo, args)) -> Some(None, minfo, args) - | E(CombTerm(InstanceMethodCallOp minfo, (obj::args))) -> Some(Some(obj), minfo, args) + | E (CombTerm (InstanceMethodCallOp minfo, (obj :: args))) -> Some(Some(obj), minfo, args) // A StaticMethodCallWOp matches as if it were a StaticMethodCallOp - | E(CombTerm(StaticMethodCallWOp (minfo, _minfoW, nWitnesses), args)) when nWitnesses <= args.Length -> + | E (CombTerm (StaticMethodCallWOp (minfo, _minfoW, nWitnesses), args)) when nWitnesses <= args.Length -> Some(None, minfo, List.skip nWitnesses args) // A InstanceMethodCallWOp matches as if it were a InstanceMethodCallOp - | E(CombTerm(InstanceMethodCallWOp (minfo, _minfoW, nWitnesses), obj::argsWithoutObj)) when nWitnesses <= argsWithoutObj.Length -> + | E (CombTerm (InstanceMethodCallWOp (minfo, _minfoW, nWitnesses), obj :: argsWithoutObj)) when + nWitnesses <= argsWithoutObj.Length + -> let argsWithoutWitnesses = List.skip nWitnesses argsWithoutObj - Some (Some obj, minfo, argsWithoutWitnesses) + Some(Some obj, minfo, argsWithoutWitnesses) | _ -> None [] let (|CallWithWitnesses|_|) input = match input with - | E(CombTerm(StaticMethodCallWOp (minfo, minfoW, nWitnesses), args)) -> + | E (CombTerm (StaticMethodCallWOp (minfo, minfoW, nWitnesses), args)) -> if args.Length >= nWitnesses then let witnessArgs, argsWithoutWitnesses = List.splitAt nWitnesses args Some(None, minfo, minfoW, witnessArgs, argsWithoutWitnesses) else None - | E(CombTerm(InstanceMethodCallWOp (minfo, minfoW, nWitnesses), obj::argsWithoutObj)) -> + | E (CombTerm (InstanceMethodCallWOp (minfo, minfoW, nWitnesses), obj :: argsWithoutObj)) -> if argsWithoutObj.Length >= nWitnesses then let witnessArgs, argsWithoutWitnesses = List.splitAt nWitnesses argsWithoutObj - Some (Some obj, minfo, minfoW, witnessArgs, argsWithoutWitnesses) + Some(Some obj, minfo, minfoW, witnessArgs, argsWithoutWitnesses) else None @@ -588,36 +803,38 @@ module Patterns = let (|LetRaw|_|) input = match input with - | Comb2(LetOp, e1, e2) -> Some(e1, e2) + | Comb2 (LetOp, e1, e2) -> Some(e1, e2) | _ -> None let (|LetRecRaw|_|) input = match input with - | Comb1(LetRecOp, e1) -> Some e1 + | Comb1 (LetRecOp, e1) -> Some e1 | _ -> None [] - let (|Let|_|)input = + let (|Let|_|) input = match input with - | LetRaw(e, Lambda(v, body)) -> Some(v, e, body) + | LetRaw (e, Lambda (v, body)) -> Some(v, e, body) | _ -> None - let (|IteratedLambda|_|) (e: Expr) = qOneOrMoreRLinear (|Lambda|_|) e + let (|IteratedLambda|_|) (e: Expr) = + qOneOrMoreRLinear (|Lambda|_|) e let rec (|NLambdas|_|) n (e: Expr) = match e with | _ when n <= 0 -> Some([], e) - | Lambda(v, NLambdas ((-) n 1) (vs, b)) -> Some(v :: vs, b) + | Lambda (v, NLambdas ((-) n 1) (vs, b)) -> Some(v :: vs, b) | _ -> None [] - let (|NewDelegate|_|) input = + let (|NewDelegate|_|) input = match input with - | Comb1(NewDelegateOp ty, e) -> + | Comb1 (NewDelegateOp ty, e) -> let nargs = (getDelegateInvoke ty).GetParameters().Length + if nargs = 0 then match e with - | NLambdas 1 ([_], e) -> Some(ty, [], e) // try to strip the unit parameter if there is one + | NLambdas 1 ([ _ ], e) -> Some(ty, [], e) // try to strip the unit parameter if there is one | NLambdas 0 ([], e) -> Some(ty, [], e) | _ -> None else @@ -629,7 +846,7 @@ module Patterns = [] let (|LetRecursive|_|) input = match input with - | LetRecRaw(IteratedLambda(vs1, E(CombTerm(LetRecCombOp, body :: es)))) -> Some(List.zip vs1 es, body) + | LetRecRaw (IteratedLambda (vs1, E (CombTerm (LetRecCombOp, body :: es)))) -> Some(List.zip vs1 es, body) | _ -> None //-------------------------------------------------------------------------- @@ -637,44 +854,58 @@ module Patterns = //-------------------------------------------------------------------------- // Returns record member specified by name - let getRecordProperty(ty, fieldName) = + let getRecordProperty (ty, fieldName) = let mems = FSharpType.GetRecordFields(ty, publicOrPrivateBindingFlags) + match mems |> Array.tryFind (fun minfo -> minfo.Name = fieldName) with | Some (m) -> m - | _ -> invalidArg "fieldName" (String.Format(SR.GetString(SR.QmissingRecordField), ty.FullName, fieldName)) + | _ -> invalidArg "fieldName" (String.Format(SR.GetString(SR.QmissingRecordField), ty.FullName, fieldName)) - let getUnionCaseInfo(ty, unionCaseName) = + let getUnionCaseInfo (ty, unionCaseName) = let cases = FSharpType.GetUnionCases(ty, publicOrPrivateBindingFlags) + match cases |> Array.tryFind (fun ucase -> ucase.Name = unionCaseName) with | Some case -> case - | _ -> invalidArg "unionCaseName" (String.Format(SR.GetString(SR.QmissingUnionCase), ty.FullName, unionCaseName)) + | _ -> + invalidArg "unionCaseName" (String.Format(SR.GetString(SR.QmissingUnionCase), ty.FullName, unionCaseName)) - let getUnionCaseInfoField(unionCase:UnionCaseInfo, index) = + let getUnionCaseInfoField (unionCase: UnionCaseInfo, index) = let fields = unionCase.GetFields() - if index < 0 || index >= fields.Length then invalidArg "index" (SR.GetString(SR.QinvalidCaseIndex)) + + if index < 0 || index >= fields.Length then + invalidArg "index" (SR.GetString(SR.QinvalidCaseIndex)) + fields.[index] /// Returns type of lambda application - something like "(fun a -> ..) b" let rec typeOfAppliedLambda f = let fty = ((typeOf f): Type) + match fty.GetGenericArguments() with - | [| _; b|] -> b + | [| _; b |] -> b | _ -> invalidOp (SR.GetString(SR.QillFormedAppOrLet)) /// Returns type of the Raw quotation or fails if the quotation is ill formed /// if 'verify' is true, verifies all branches, otherwise ignores some of them when not needed - and typeOf<'T when 'T :> Expr> (e : 'T): Type = + and typeOf<'T when 'T :> Expr> (e: 'T) : Type = let (E t) = e + match t with - | VarTerm v -> v.Type + | VarTerm v -> v.Type | LambdaTerm (v, b) -> mkFunTy v.Type (typeOf b) - | HoleTerm (ty, _) -> ty - | CombTerm (c, args) -> + | HoleTerm (ty, _) -> ty + | CombTerm (c, args) -> match c, args with - | AppOp, [f;_] -> typeOfAppliedLambda f - | LetOp, _ -> match e with Let(_, _, b) -> typeOf b | _ -> failwith "unreachable" - | IfThenElseOp, [_;t;_] -> typeOf t - | LetRecOp, _ -> match e with LetRecursive(_, b) -> typeOf b | _ -> failwith "unreachable" + | AppOp, [ f; _ ] -> typeOfAppliedLambda f + | LetOp, _ -> + match e with + | Let (_, _, b) -> typeOf b + | _ -> failwith "unreachable" + | IfThenElseOp, [ _; t; _ ] -> typeOf t + | LetRecOp, _ -> + match e with + | LetRecursive (_, b) -> typeOf b + | _ -> failwith "unreachable" | LetRecCombOp, _ -> failwith "typeOfConst: LetRecCombOp" | NewRecordOp ty, _ -> ty | NewUnionCaseOp unionCase, _ -> unionCase.DeclaringType @@ -697,33 +928,50 @@ module Patterns = | InstanceMethodCallWOp (_, minfoW, _), _ -> minfoW.ReturnType |> removeVoid | StaticMethodCallWOp (_, minfoW, _), _ -> minfoW.ReturnType |> removeVoid | CoerceOp ty, _ -> ty - | SequentialOp, [_;b] -> typeOf b + | SequentialOp, [ _; b ] -> typeOf b | ForIntegerRangeLoopOp, _ -> typeof | NewArrayOp ty, _ -> mkArrayTy ty | NewDelegateOp ty, _ -> ty | DefaultValueOp ty, _ -> ty | TypeTestOp _, _ -> typeof - | QuoteOp true, [expr] -> mkExprTy (typeOf expr) - | QuoteOp false, [_] -> rawExprTy - | TryFinallyOp, [e1;_] -> typeOf e1 - | TryWithOp, [e1;_;_] -> typeOf e1 + | QuoteOp true, [ expr ] -> mkExprTy (typeOf expr) + | QuoteOp false, [ _ ] -> rawExprTy + | TryFinallyOp, [ e1; _ ] -> typeOf e1 + | TryWithOp, [ e1; _; _ ] -> typeOf e1 | WhileLoopOp, _ | VarSetOp, _ | AddressSetOp, _ -> typeof - | AddressOfOp, [expr]-> (typeOf expr).MakeByRefType() - | (AddressOfOp | QuoteOp _ | SequentialOp | TryWithOp | TryFinallyOp | IfThenElseOp | AppOp), _ -> failwith "unreachable" - + | AddressOfOp, [ expr ] -> (typeOf expr).MakeByRefType() + | (AddressOfOp + | QuoteOp _ + | SequentialOp + | TryWithOp + | TryFinallyOp + | IfThenElseOp + | AppOp), + _ -> failwith "unreachable" //-------------------------------------------------------------------------- // Constructors for building Raw quotations //-------------------------------------------------------------------------- - let mkFEN op l = E(CombTerm(op, l)) - let mkFE0 op = E(CombTerm(op, [])) - let mkFE1 op x = E(CombTerm(op, [(x:>Expr)])) - let mkFE2 op (x, y) = E(CombTerm(op, [(x:>Expr);(y:>Expr)])) - let mkFE3 op (x, y, z) = E(CombTerm(op, [(x:>Expr);(y:>Expr);(z:>Expr)]) ) - let mkOp v () = v + let mkFEN op l = + E(CombTerm(op, l)) + + let mkFE0 op = + E(CombTerm(op, [])) + + let mkFE1 op x = + E(CombTerm(op, [ (x :> Expr) ])) + + let mkFE2 op (x, y) = + E(CombTerm(op, [ (x :> Expr); (y :> Expr) ])) + + let mkFE3 op (x, y, z) = + E(CombTerm(op, [ (x :> Expr); (y :> Expr); (z :> Expr) ])) + + let mkOp v () = + v //-------------------------------------------------------------------------- // Type-checked constructors for building Raw quotations @@ -733,79 +981,136 @@ module Patterns = let assignableFrom (t1: Type) (t2: Type) = t1.IsAssignableFrom t2 - let checkTypesSR (expectedType: Type) (receivedType: Type) name (threeHoleSR : string) = + let checkTypesSR (expectedType: Type) (receivedType: Type) name (threeHoleSR: string) = if (expectedType <> receivedType) then - invalidArg "receivedType" (String.Format(threeHoleSR, name, expectedType, receivedType)) + invalidArg "receivedType" (String.Format(threeHoleSR, name, expectedType, receivedType)) - let checkTypesWeakSR (expectedType: Type) (receivedType: Type) name (threeHoleSR : string) = + let checkTypesWeakSR (expectedType: Type) (receivedType: Type) name (threeHoleSR: string) = if (not (assignableFrom expectedType receivedType)) then - invalidArg "receivedType" (String.Format(threeHoleSR, name, expectedType, receivedType)) + invalidArg "receivedType" (String.Format(threeHoleSR, name, expectedType, receivedType)) let checkArgs (paramInfos: ParameterInfo[]) (args: Expr list) = - if (paramInfos.Length <> args.Length) then invalidArg "args" (SR.GetString(SR.QincorrectNumArgs)) + if (paramInfos.Length <> args.Length) then + invalidArg "args" (SR.GetString(SR.QincorrectNumArgs)) + List.iter2 - ( fun (p:ParameterInfo) a -> checkTypesWeakSR p.ParameterType (typeOf a) "args" (SR.GetString(SR.QtmmInvalidParam))) + (fun (p: ParameterInfo) a -> + checkTypesWeakSR p.ParameterType (typeOf a) "args" (SR.GetString(SR.QtmmInvalidParam))) (paramInfos |> Array.toList) args - // todo: shouldn't this be "strong" type check? sometimes? + // todo: shouldn't this be "strong" type check? sometimes? let checkAssignableFrom ty1 ty2 = - if not (assignableFrom ty1 ty2) then invalidArg "ty2" (SR.GetString(SR.QincorrectType)) + if not (assignableFrom ty1 ty2) then + invalidArg "ty2" (SR.GetString(SR.QincorrectType)) - let checkObj (membInfo: MemberInfo) (obj: Expr) = + let checkObj (membInfo: MemberInfo) (obj: Expr) = // The MemberInfo may be a property associated with a union // find the actual related union type - let rec loop (ty: Type) = if FSharpType.IsUnion ty && FSharpType.IsUnion ty.BaseType then loop ty.BaseType else ty + let rec loop (ty: Type) = + if FSharpType.IsUnion ty && FSharpType.IsUnion ty.BaseType then + loop ty.BaseType + else + ty + let declType = loop membInfo.DeclaringType - if not (assignableFrom declType (typeOf obj)) then invalidArg "obj" (SR.GetString(SR.QincorrectInstanceType)) + if not (assignableFrom declType (typeOf obj)) then + invalidArg "obj" (SR.GetString(SR.QincorrectInstanceType)) // Checks lambda application for correctness let checkAppliedLambda (f, v) = let fty = typeOf f - let ftyG = (if fty.IsGenericType then fty.GetGenericTypeDefinition() else fty) + + let ftyG = + (if fty.IsGenericType then + fty.GetGenericTypeDefinition() + else + fty) + checkTypesSR funTyC ftyG "f" (SR.GetString(SR.QtmmExpectedFunction)) let vty = (typeOf v) + match fty.GetGenericArguments() with - | [| a; _ |] -> checkTypesSR vty a "f" (SR.GetString(SR.QtmmFunctionArgTypeMismatch)) - | _ -> invalidArg "f" (SR.GetString(SR.QinvalidFuncType)) + | [| a; _ |] -> checkTypesSR vty a "f" (SR.GetString(SR.QtmmFunctionArgTypeMismatch)) + | _ -> invalidArg "f" (SR.GetString(SR.QinvalidFuncType)) // Returns option (by name) of a NewUnionCase type let getUnionCaseFields ty str = let cases = FSharpType.GetUnionCases(ty, publicOrPrivateBindingFlags) + match cases |> Array.tryFind (fun ucase -> ucase.Name = str) with | Some case -> case.GetFields() - | _ -> invalidArg "ty" (String.Format(SR.GetString(SR.notAUnionType), ty.FullName)) + | _ -> invalidArg "ty" (String.Format(SR.GetString(SR.notAUnionType), ty.FullName)) - let checkBind(v: Var, e) = + let checkBind (v: Var, e) = let ety = typeOf e checkTypesSR v.Type ety "let" (SR.GetString(SR.QtmmVarTypeNotMatchRHS)) // [Correct by definition] - let mkVar v = E(VarTerm v ) - let mkQuote(a, isTyped) = E(CombTerm(QuoteOp isTyped, [(a:>Expr)] )) + let mkVar v = + E(VarTerm v) + + let mkQuote (a, isTyped) = + E(CombTerm(QuoteOp isTyped, [ (a :> Expr) ])) + + let mkValue (v, ty) = + mkFE0 (ValueOp(v, ty, None)) + + let mkValueWithName (v, ty, nm) = + mkFE0 (ValueOp(v, ty, Some nm)) + + let mkValueWithDefn (v, ty, defn) = + mkFE1 (WithValueOp(v, ty)) defn + + let mkValueG (v: 'T) = + mkValue (box v, typeof<'T>) - let mkValue (v, ty) = mkFE0 (ValueOp(v, ty, None)) - let mkValueWithName (v, ty, nm) = mkFE0 (ValueOp(v, ty, Some nm)) - let mkValueWithDefn (v, ty, defn) = mkFE1 (WithValueOp(v, ty)) defn - let mkValueG (v: 'T) = mkValue(box v, typeof<'T>) let mkLiftedValueOpG (v, ty: System.Type) = - let obj = if ty.IsEnum then System.Enum.ToObject(ty, box v) else box v + let obj = + if ty.IsEnum then + System.Enum.ToObject(ty, box v) + else + box v + ValueOp(obj, ty, None) - let mkUnit () = mkValue(null, typeof) - let mkAddressOf v = mkFE1 AddressOfOp v - let mkSequential (e1, e2) = mkFE2 SequentialOp (e1, e2) - let mkTypeTest (e, ty) = mkFE1 (TypeTestOp ty) e - let mkVarSet (v, e) = mkFE2 VarSetOp (mkVar v, e) - let mkAddressSet (e1, e2) = mkFE2 AddressSetOp (e1, e2) - let mkLambda(var, body) = E(LambdaTerm(var, (body:>Expr))) - let mkTryWith(e1, v1, e2, v2, e3) = mkFE3 TryWithOp (e1, mkLambda(v1, e2), mkLambda(v2, e3)) - let mkTryFinally(e1, e2) = mkFE2 TryFinallyOp (e1, e2) - let mkCoerce (ty, x) = mkFE1 (CoerceOp ty) x - let mkNull (ty) = mkFE0 (ValueOp(null, ty, None)) + let mkUnit () = + mkValue (null, typeof) + + let mkAddressOf v = + mkFE1 AddressOfOp v + + let mkSequential (e1, e2) = + mkFE2 SequentialOp (e1, e2) + + let mkTypeTest (e, ty) = + mkFE1 (TypeTestOp ty) e + + let mkVarSet (v, e) = + mkFE2 VarSetOp (mkVar v, e) - let mkApplication v = checkAppliedLambda v; mkFE2 AppOp v + let mkAddressSet (e1, e2) = + mkFE2 AddressSetOp (e1, e2) + + let mkLambda (var, body) = + E(LambdaTerm(var, (body :> Expr))) + + let mkTryWith (e1, v1, e2, v2, e3) = + mkFE3 TryWithOp (e1, mkLambda (v1, e2), mkLambda (v2, e3)) + + let mkTryFinally (e1, e2) = + mkFE2 TryFinallyOp (e1, e2) + + let mkCoerce (ty, x) = + mkFE1 (CoerceOp ty) x + + let mkNull (ty) = + mkFE0 (ValueOp(null, ty, None)) + + let mkApplication v = + checkAppliedLambda v + mkFE2 AppOp v let mkLetRaw v = mkFE2 LetOp v @@ -815,10 +1120,13 @@ module Patterns = mkLetRaw v // Tuples - let mkNewTupleWithType (ty, args: Expr list) = + let mkNewTupleWithType (ty, args: Expr list) = let mems = FSharpType.GetTupleElements ty |> Array.toList - if (args.Length <> mems.Length) then invalidArg "args" (SR.GetString(SR.QtupleLengthsDiffer)) - List.iter2(fun mt a -> checkTypesSR mt (typeOf a) "args" (SR.GetString(SR.QtmmTuple)) ) mems args + + if (args.Length <> mems.Length) then + invalidArg "args" (SR.GetString(SR.QtupleLengthsDiffer)) + + List.iter2 (fun mt a -> checkTypesSR mt (typeOf a) "args" (SR.GetString(SR.QtmmTuple))) mems args mkFEN (NewTupleOp ty) args let mkNewTuple (args) = @@ -832,27 +1140,49 @@ module Patterns = let mkTupleGet (ty, n, x) = checkTypesSR ty (typeOf x) "tupleGet" (SR.GetString(SR.QtmmExprNotMatchTuple)) let mems = FSharpType.GetTupleElements ty - if (n < 0 || mems.Length <= n) then invalidArg "n" (SR.GetString(SR.QtupleAccessOutOfRange)) - mkFE1 (TupleGetOp (ty, n)) x + + if (n < 0 || mems.Length <= n) then + invalidArg "n" (SR.GetString(SR.QtupleAccessOutOfRange)) + + mkFE1 (TupleGetOp(ty, n)) x // Records let mkNewRecord (ty, args: Expr list) = let mems = FSharpType.GetRecordFields(ty, publicOrPrivateBindingFlags) - if (args.Length <> mems.Length) then invalidArg "args" (SR.GetString(SR.QincompatibleRecordLength)) - List.iter2 (fun (minfo: PropertyInfo) a -> checkTypesSR minfo.PropertyType (typeOf a) "recd" (SR.GetString(SR.QtmmIncorrectArgForRecord))) (Array.toList mems) args - mkFEN (NewRecordOp ty) args + if (args.Length <> mems.Length) then + invalidArg "args" (SR.GetString(SR.QincompatibleRecordLength)) + + List.iter2 + (fun (minfo: PropertyInfo) a -> + checkTypesSR minfo.PropertyType (typeOf a) "recd" (SR.GetString(SR.QtmmIncorrectArgForRecord))) + (Array.toList mems) + args + + mkFEN (NewRecordOp ty) args // Discriminated unions - let mkNewUnionCase (unionCase:UnionCaseInfo, args: Expr list) = - if Unchecked.defaultof = unionCase then raise (new ArgumentNullException()) + let mkNewUnionCase (unionCase: UnionCaseInfo, args: Expr list) = + if Unchecked.defaultof = unionCase then + raise (new ArgumentNullException()) + let sargs = unionCase.GetFields() - if (args.Length <> sargs.Length) then invalidArg "args" (SR.GetString(SR.QunionNeedsDiffNumArgs)) - List.iter2 (fun (minfo: PropertyInfo) a -> checkTypesSR minfo.PropertyType (typeOf a) "sum" (SR.GetString(SR.QtmmIncorrectArgForUnion))) (Array.toList sargs) args + + if (args.Length <> sargs.Length) then + invalidArg "args" (SR.GetString(SR.QunionNeedsDiffNumArgs)) + + List.iter2 + (fun (minfo: PropertyInfo) a -> + checkTypesSR minfo.PropertyType (typeOf a) "sum" (SR.GetString(SR.QtmmIncorrectArgForUnion))) + (Array.toList sargs) + args + mkFEN (NewUnionCaseOp unionCase) args - let mkUnionCaseTest (unionCase:UnionCaseInfo, expr) = - if Unchecked.defaultof = unionCase then raise (new ArgumentNullException()) + let mkUnionCaseTest (unionCase: UnionCaseInfo, expr) = + if Unchecked.defaultof = unionCase then + raise (new ArgumentNullException()) + checkTypesSR unionCase.DeclaringType (typeOf expr) "UnionCaseTagTest" (SR.GetString(SR.QtmmExprTypeMismatch)) mkFE1 (UnionCaseTestOp unionCase) expr @@ -866,38 +1196,50 @@ module Patterns = List.iter (fun a -> checkTypesSR ty (typeOf a) "newArray" (SR.GetString(SR.QtmmInitArray))) args mkFEN (NewArrayOp ty) args - let mkInstanceFieldGet(obj, finfo:FieldInfo) = - if Unchecked.defaultof = finfo then raise (new ArgumentNullException()) + let mkInstanceFieldGet (obj, finfo: FieldInfo) = + if Unchecked.defaultof = finfo then + raise (new ArgumentNullException()) + match finfo.IsStatic with | false -> checkObj finfo obj mkFE1 (InstanceFieldGetOp finfo) obj - | true -> invalidArg "finfo" (SR.GetString(SR.QstaticWithReceiverObject)) + | true -> invalidArg "finfo" (SR.GetString(SR.QstaticWithReceiverObject)) + + let mkStaticFieldGet (finfo: FieldInfo) = + if Unchecked.defaultof = finfo then + raise (new ArgumentNullException()) - let mkStaticFieldGet (finfo:FieldInfo) = - if Unchecked.defaultof = finfo then raise (new ArgumentNullException()) match finfo.IsStatic with | true -> mkFE0 (StaticFieldGetOp finfo) - | false -> invalidArg "finfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + | false -> invalidArg "finfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + + let mkStaticFieldSet (finfo: FieldInfo, value: Expr) = + if Unchecked.defaultof = finfo then + raise (new ArgumentNullException()) - let mkStaticFieldSet (finfo:FieldInfo, value: Expr) = - if Unchecked.defaultof = finfo then raise (new ArgumentNullException()) checkTypesSR (typeOf value) finfo.FieldType "value" (SR.GetString(SR.QtmmBadFieldType)) + match finfo.IsStatic with | true -> mkFE1 (StaticFieldSetOp finfo) value - | false -> invalidArg "finfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + | false -> invalidArg "finfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + + let mkInstanceFieldSet (obj, finfo: FieldInfo, value: Expr) = + if Unchecked.defaultof = finfo then + raise (new ArgumentNullException()) - let mkInstanceFieldSet (obj, finfo:FieldInfo, value: Expr) = - if Unchecked.defaultof = finfo then raise (new ArgumentNullException()) checkTypesSR (typeOf value) finfo.FieldType "value" (SR.GetString(SR.QtmmBadFieldType)) + match finfo.IsStatic with | false -> checkObj finfo obj mkFE2 (InstanceFieldSetOp finfo) (obj, value) - | true -> invalidArg "finfo" (SR.GetString(SR.QstaticWithReceiverObject)) + | true -> invalidArg "finfo" (SR.GetString(SR.QstaticWithReceiverObject)) + + let mkCtorCall (ci: ConstructorInfo, args: Expr list) = + if Unchecked.defaultof = ci then + raise (new ArgumentNullException()) - let mkCtorCall (ci:ConstructorInfo, args: Expr list) = - if Unchecked.defaultof = ci then raise (new ArgumentNullException()) checkArgs (ci.GetParameters()) args mkFEN (NewObjectOp ci) args @@ -905,78 +1247,110 @@ module Patterns = mkFE0 (DefaultValueOp ty) let mkStaticPropGet (pinfo: PropertyInfo, args: Expr list) = - if Unchecked.defaultof = pinfo then raise (new ArgumentNullException()) - if (not pinfo.CanRead) then invalidArg "pinfo" (SR.GetString(SR.QreadingSetOnly)) + if Unchecked.defaultof = pinfo then + raise (new ArgumentNullException()) + + if (not pinfo.CanRead) then + invalidArg "pinfo" (SR.GetString(SR.QreadingSetOnly)) + checkArgs (pinfo.GetIndexParameters()) args + match pinfo.GetGetMethod(true).IsStatic with - | true -> mkFEN (StaticPropGetOp pinfo) args - | false -> invalidArg "pinfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + | true -> mkFEN (StaticPropGetOp pinfo) args + | false -> invalidArg "pinfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) let mkInstancePropGet (obj, pinfo: PropertyInfo, args: Expr list) = - if Unchecked.defaultof = pinfo then raise (new ArgumentNullException()) - if (not pinfo.CanRead) then invalidArg "pinfo" (SR.GetString(SR.QreadingSetOnly)) + if Unchecked.defaultof = pinfo then + raise (new ArgumentNullException()) + + if (not pinfo.CanRead) then + invalidArg "pinfo" (SR.GetString(SR.QreadingSetOnly)) + checkArgs (pinfo.GetIndexParameters()) args + match pinfo.GetGetMethod(true).IsStatic with | false -> checkObj pinfo obj mkFEN (InstancePropGetOp pinfo) (obj :: args) - | true -> invalidArg "pinfo" (SR.GetString(SR.QstaticWithReceiverObject)) + | true -> invalidArg "pinfo" (SR.GetString(SR.QstaticWithReceiverObject)) let mkStaticPropSet (pinfo: PropertyInfo, args: Expr list, value: Expr) = - if Unchecked.defaultof = pinfo then raise (new ArgumentNullException()) - if (not pinfo.CanWrite) then invalidArg "pinfo" (SR.GetString(SR.QwritingGetOnly)) + if Unchecked.defaultof = pinfo then + raise (new ArgumentNullException()) + + if (not pinfo.CanWrite) then + invalidArg "pinfo" (SR.GetString(SR.QwritingGetOnly)) + checkArgs (pinfo.GetIndexParameters()) args + match pinfo.GetSetMethod(true).IsStatic with - | true -> mkFEN (StaticPropSetOp pinfo) (args@[value]) - | false -> invalidArg "pinfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + | true -> mkFEN (StaticPropSetOp pinfo) (args @ [ value ]) + | false -> invalidArg "pinfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) let mkInstancePropSet (obj, pinfo: PropertyInfo, args: Expr list, value: Expr) = - if Unchecked.defaultof = pinfo then raise (new ArgumentNullException()) - if (not pinfo.CanWrite) then invalidArg "pinfo" (SR.GetString(SR.QwritingGetOnly)) + if Unchecked.defaultof = pinfo then + raise (new ArgumentNullException()) + + if (not pinfo.CanWrite) then + invalidArg "pinfo" (SR.GetString(SR.QwritingGetOnly)) + checkArgs (pinfo.GetIndexParameters()) args + match pinfo.GetSetMethod(true).IsStatic with | false -> checkObj pinfo obj - mkFEN (InstancePropSetOp pinfo) (obj :: (args@[value])) - | true -> invalidArg "pinfo" (SR.GetString(SR.QstaticWithReceiverObject)) + mkFEN (InstancePropSetOp pinfo) (obj :: (args @ [ value ])) + | true -> invalidArg "pinfo" (SR.GetString(SR.QstaticWithReceiverObject)) + + let mkInstanceMethodCall (obj, minfo: MethodInfo, args: Expr list) = + if Unchecked.defaultof = minfo then + raise (new ArgumentNullException()) - let mkInstanceMethodCall (obj, minfo:MethodInfo, args: Expr list) = - if Unchecked.defaultof = minfo then raise (new ArgumentNullException()) checkArgs (minfo.GetParameters()) args + match minfo.IsStatic with | false -> checkObj minfo obj mkFEN (InstanceMethodCallOp minfo) (obj :: args) - | true -> invalidArg "minfo" (SR.GetString(SR.QstaticWithReceiverObject)) + | true -> invalidArg "minfo" (SR.GetString(SR.QstaticWithReceiverObject)) let mkInstanceMethodCallW (obj, minfo: MethodInfo, minfoW: MethodInfo, nWitnesses: int, args: Expr list) = - if Unchecked.defaultof = minfo then raise (new ArgumentNullException()) + if Unchecked.defaultof = minfo then + raise (new ArgumentNullException()) + checkArgs (minfoW.GetParameters()) args + match minfoW.IsStatic with | false -> checkObj minfo obj - mkFEN (InstanceMethodCallWOp (minfo, minfoW, nWitnesses)) (obj::args) - | true -> invalidArg "minfo" (SR.GetString(SR.QstaticWithReceiverObject)) + mkFEN (InstanceMethodCallWOp(minfo, minfoW, nWitnesses)) (obj :: args) + | true -> invalidArg "minfo" (SR.GetString(SR.QstaticWithReceiverObject)) + + let mkStaticMethodCall (minfo: MethodInfo, args: Expr list) = + if Unchecked.defaultof = minfo then + raise (new ArgumentNullException()) - let mkStaticMethodCall (minfo:MethodInfo, args: Expr list) = - if Unchecked.defaultof = minfo then raise (new ArgumentNullException()) checkArgs (minfo.GetParameters()) args + match minfo.IsStatic with | true -> mkFEN (StaticMethodCallOp minfo) args - | false -> invalidArg "minfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + | false -> invalidArg "minfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) let mkStaticMethodCallW (minfo: MethodInfo, minfoW: MethodInfo, nWitnesses: int, args: Expr list) = - if Unchecked.defaultof = minfo then raise (new ArgumentNullException()) + if Unchecked.defaultof = minfo then + raise (new ArgumentNullException()) + checkArgs (minfoW.GetParameters()) args + match minfo.IsStatic with - | true -> mkFEN (StaticMethodCallWOp (minfo, minfoW, nWitnesses)) args - | false -> invalidArg "minfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) + | true -> mkFEN (StaticMethodCallWOp(minfo, minfoW, nWitnesses)) args + | false -> invalidArg "minfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) let mkForLoop (v: Var, lowerBound, upperBound, body) = checkTypesSR (typeof) (typeOf lowerBound) "lowerBound" (SR.GetString(SR.QtmmLowerUpperBoundMustBeInt)) checkTypesSR (typeof) (typeOf upperBound) "upperBound" (SR.GetString(SR.QtmmLowerUpperBoundMustBeInt)) checkTypesSR (typeof) (v.Type) "for" (SR.GetString(SR.QtmmLoopBodyMustBeLambdaTakingInteger)) - mkFE3 ForIntegerRangeLoopOp (lowerBound, upperBound, mkLambda(v, body)) + mkFE3 ForIntegerRangeLoopOp (lowerBound, upperBound, mkLambda (v, body)) let mkWhileLoop (guard, body) = checkTypesSR (typeof) (typeOf guard) "guard" (SR.GetString(SR.QtmmGuardMustBeBool)) @@ -986,31 +1360,40 @@ module Patterns = let mkNewDelegate (ty, e) = let mi = getDelegateInvoke ty let ps = mi.GetParameters() - let dlfun = Array.foldBack (fun (p:ParameterInfo) retTy -> mkFunTy p.ParameterType retTy) ps mi.ReturnType + + let dlfun = + Array.foldBack (fun (p: ParameterInfo) retTy -> mkFunTy p.ParameterType retTy) ps mi.ReturnType + checkTypesSR dlfun (typeOf e) "ty" (SR.GetString(SR.QtmmFunTypeNotMatchDelegate)) mkFE1 (NewDelegateOp ty) e let mkLet (v, e, b) = checkBind (v, e) - mkLetRaw (e, mkLambda(v, b)) + mkLetRaw (e, mkLambda (v, b)) //let mkLambdas(vs, b) = mkRLinear mkLambdaRaw (vs, (b:>Expr)) let mkTupledApplication (f, args) = match args with - | [] -> mkApplication (f, mkUnit()) - | [x] -> mkApplication (f, x) + | [] -> mkApplication (f, mkUnit ()) + | [ x ] -> mkApplication (f, x) | _ -> mkApplication (f, mkNewTuple args) - let mkApplications(f: Expr, es: Expr list list) = mkLLinear mkTupledApplication (f, es) + let mkApplications (f: Expr, es: Expr list list) = + mkLLinear mkTupledApplication (f, es) + + let mkIteratedLambdas (vs, b) = + mkRLinear mkLambda (vs, b) + + let mkLetRecRaw v = + mkFE1 LetRecOp v - let mkIteratedLambdas(vs, b) = mkRLinear mkLambda (vs, b) + let mkLetRecCombRaw v = + mkFEN LetRecCombOp v - let mkLetRecRaw v = mkFE1 LetRecOp v - let mkLetRecCombRaw v = mkFEN LetRecCombOp v - let mkLetRec (ves:(Var*Expr) list, body) = + let mkLetRec (ves: (Var * Expr) list, body) = List.iter checkBind ves let vs, es = List.unzip ves - mkLetRecRaw(mkIteratedLambdas (vs, mkLetRecCombRaw (body :: es))) + mkLetRecRaw (mkIteratedLambdas (vs, mkLetRecCombRaw (body :: es))) let ReflectedDefinitionsResourceNameBase = "ReflectedDefinitions" @@ -1025,77 +1408,107 @@ module Patterns = | Unique of 'T | Ambiguous of 'R - let typeEquals (s: Type) (t: Type) = s.Equals t + let typeEquals (s: Type) (t: Type) = + s.Equals t let typesEqual (ss: Type list) (tt: Type list) = - (ss.Length = tt.Length) && List.forall2 typeEquals ss tt + (ss.Length = tt.Length) && List.forall2 typeEquals ss tt - let instFormal (typarEnv: Type[]) (ty:Instantiable<'T>) = ty (fun i -> typarEnv.[i]) + let instFormal (typarEnv: Type[]) (ty: Instantiable<'T>) = + ty (fun i -> typarEnv.[i]) - let getGenericArguments(genericType: Type) = - if genericType.IsGenericType then genericType.GetGenericArguments() else [| |] + let getGenericArguments (genericType: Type) = + if genericType.IsGenericType then + genericType.GetGenericArguments() + else + [||] - let getNumGenericArguments(genericType: Type) = - if genericType.IsGenericType then genericType.GetGenericArguments().Length else 0 + let getNumGenericArguments (genericType: Type) = + if genericType.IsGenericType then + genericType.GetGenericArguments().Length + else + 0 let bindMethodBySearch (knownArgCount: int voption, parentT: Type, nm, marity, argTys, retTy) = let methInfos = parentT.GetMethods staticOrInstanceBindingFlags |> Array.toList // First, filter on name, if unique, then binding "done" let tyargTs = getGenericArguments parentT let methInfos = methInfos |> List.filter (fun methInfo -> methInfo.Name = nm) + match methInfos with - | [methInfo] -> - methInfo + | [ methInfo ] -> methInfo | _ -> // Second, type match. - let select (methInfo:MethodInfo) = + let select (methInfo: MethodInfo) = // mref implied Types - let mtyargTIs = if methInfo.IsGenericMethod then methInfo.GetGenericArguments() else [| |] - if mtyargTIs.Length <> marity then false (* method generic arity mismatch *) else - let typarEnv = (Array.append tyargTs mtyargTIs) - let argTs = argTys |> List.map (instFormal typarEnv) - let resT = instFormal typarEnv retTy - - // methInfo implied Types - let haveArgTs = - let parameters = Array.toList (methInfo.GetParameters()) - parameters |> List.map (fun param -> param.ParameterType) - let haveResT = methInfo.ReturnType - - let nargTs = argTs.Length - - // check for match - if nargTs <> haveArgTs.Length then false (* method argument length mismatch *) else - - // If a known-number-of-arguments-including-object-argument has been given then check that - if (match knownArgCount with - | ValueNone -> false - | ValueSome n -> n <> (if methInfo.IsStatic then 0 else 1) + nargTs) then false else - - let res = typesEqual (resT :: argTs) (haveResT :: haveArgTs) - res + let mtyargTIs = + if methInfo.IsGenericMethod then + methInfo.GetGenericArguments() + else + [||] + + if mtyargTIs.Length <> marity then + false (* method generic arity mismatch *) + else + let typarEnv = (Array.append tyargTs mtyargTIs) + let argTs = argTys |> List.map (instFormal typarEnv) + let resT = instFormal typarEnv retTy + + // methInfo implied Types + let haveArgTs = + let parameters = Array.toList (methInfo.GetParameters()) + parameters |> List.map (fun param -> param.ParameterType) + + let haveResT = methInfo.ReturnType + + let nargTs = argTs.Length + + // check for match + if nargTs <> haveArgTs.Length then + false (* method argument length mismatch *) + else + + // If a known-number-of-arguments-including-object-argument has been given then check that + if (match knownArgCount with + | ValueNone -> false + | ValueSome n -> n <> (if methInfo.IsStatic then 0 else 1) + nargTs) then + false + else + + let res = typesEqual (resT :: argTs) (haveResT :: haveArgTs) + res // return MethodInfo for (generic) type's (generic) method match List.tryFind select methInfos with - | None -> invalidOp (SR.GetString SR.QcannotBindToMethod) + | None -> invalidOp (SR.GetString SR.QcannotBindToMethod) | Some methInfo -> methInfo let bindMethodHelper (knownArgCount, (parentT: Type, nm, marity, argTys, retTy)) = - if isNull parentT then invalidArg "parentT" (SR.GetString(SR.QparentCannotBeNull)) - if marity = 0 then - let tyargTs = if parentT.IsGenericType then parentT.GetGenericArguments() else [| |] - let argTs = Array.ofList (List.map (instFormal tyargTs) argTys) - let resT = instFormal tyargTs retTy - let methInfo = - try - match parentT.GetMethod(nm, staticOrInstanceBindingFlags, null, argTs, null) with - | null -> None - | res -> Some res - with :? AmbiguousMatchException -> None - match methInfo with - | Some methInfo when (typeEquals resT methInfo.ReturnType) -> methInfo - | _ -> bindMethodBySearch(knownArgCount, parentT, nm, marity, argTys, retTy) - else - bindMethodBySearch(knownArgCount, parentT, nm, marity, argTys, retTy) + if isNull parentT then + invalidArg "parentT" (SR.GetString(SR.QparentCannotBeNull)) + + if marity = 0 then + let tyargTs = + if parentT.IsGenericType then + parentT.GetGenericArguments() + else + [||] + + let argTs = Array.ofList (List.map (instFormal tyargTs) argTys) + let resT = instFormal tyargTs retTy + + let methInfo = + try + match parentT.GetMethod(nm, staticOrInstanceBindingFlags, null, argTs, null) with + | null -> None + | res -> Some res + with :? AmbiguousMatchException -> + None + + match methInfo with + | Some methInfo when (typeEquals resT methInfo.ReturnType) -> methInfo + | _ -> bindMethodBySearch (knownArgCount, parentT, nm, marity, argTys, retTy) + else + bindMethodBySearch (knownArgCount, parentT, nm, marity, argTys, retTy) let bindModuleProperty (ty: Type, nm) = match ty.GetProperty(nm, staticBindingFlags) with @@ -1105,37 +1518,45 @@ module Patterns = let bindModuleFunctionWithCallSiteArgs (ty: Type, nm, argTypes: Type list, tyArgs: Type list) = let argTypes = List.toArray argTypes let tyArgs = List.toArray tyArgs + let methInfo = try match ty.GetMethod(nm, staticOrInstanceBindingFlags, null, argTypes, null) with | null -> None | res -> Some res - with :? AmbiguousMatchException -> None + with :? AmbiguousMatchException -> + None + match methInfo with | Some methInfo -> methInfo | _ -> // narrow down set of candidates by removing methods with a different name\number of arguments\number of type parameters let candidates = ty.GetMethods staticBindingFlags - |> Array.filter(fun mi -> - mi.Name = nm && - mi.GetParameters().Length = argTypes.Length && - let methodTyArgCount = if mi.IsGenericMethod then mi.GetGenericArguments().Length else 0 - methodTyArgCount = tyArgs.Length - ) - let fail() = invalidOp (String.Format(SR.GetString(SR.QcannotBindFunction), nm, ty.ToString())) + |> Array.filter (fun mi -> + mi.Name = nm + && mi.GetParameters().Length = argTypes.Length + && let methodTyArgCount = + if mi.IsGenericMethod then + mi.GetGenericArguments().Length + else + 0 in + methodTyArgCount = tyArgs.Length) + + let fail () = + invalidOp (String.Format(SR.GetString(SR.QcannotBindFunction), nm, ty.ToString())) + match candidates with - | [||] -> fail() + | [||] -> fail () | [| solution |] -> solution | candidates -> let solution = // no type arguments - just perform pairwise comparison of type in methods signature and argument type from the callsite if tyArgs.Length = 0 then candidates - |> Array.tryFind(fun mi -> + |> Array.tryFind (fun mi -> let paramTys = mi.GetParameters() |> Array.map (fun pi -> pi.ParameterType) - Array.forall2 (=) argTypes paramTys - ) + Array.forall2 (=) argTypes paramTys) else let FAIL = -1 let MATCH = 2 @@ -1154,39 +1575,53 @@ module Patterns = // - exact match with actual argument type adds MATCH value to the final result // - parameter type is generic that after instantiation matches actual argument type adds GENERIC_MATCH to the final result // - parameter type is generic that after instantiation doesn't actual argument type stops computation and return FAIL as the final result - let weight (mi : MethodInfo) = + let weight (mi: MethodInfo) = let parameters = mi.GetParameters() + let rec iter i acc = - if i >= argTypes.Length then acc - else - let param = parameters.[i] - if param.ParameterType.IsGenericParameter then - let actualTy = tyArgs.[param.ParameterType.GenericParameterPosition] - if actualTy = argTypes.[i] then iter (i + 1) (acc + GENERIC_MATCH) else FAIL + if i >= argTypes.Length then + acc else - if param.ParameterType = argTypes.[i] then iter (i + 1) (acc + MATCH) else FAIL + let param = parameters.[i] + + if param.ParameterType.IsGenericParameter then + let actualTy = tyArgs.[param.ParameterType.GenericParameterPosition] + + if actualTy = argTypes.[i] then + iter (i + 1) (acc + GENERIC_MATCH) + else + FAIL + else if param.ParameterType = argTypes.[i] then + iter (i + 1) (acc + MATCH) + else + FAIL + iter 0 0 + let solution, weight = - candidates - |> Array.map (fun mi -> mi, weight mi) - |> Array.maxBy snd - if weight = FAIL then None - else Some solution + candidates |> Array.map (fun mi -> mi, weight mi) |> Array.maxBy snd + + if weight = FAIL then + None + else + Some solution + match solution with | Some mi -> mi - | None -> fail() + | None -> fail () let mkNamedType (genericType: Type, tyargs) = - match tyargs with + match tyargs with | [] -> genericType | _ -> genericType.MakeGenericType(Array.ofList tyargs) - let inline checkNonNullResult (arg:string, err:string) y = + let inline checkNonNullResult (arg: string, err: string) y = match box y with | null -> raise (new ArgumentNullException(arg, err)) | _ -> y - let inst (tyargs: Type list) (i: Instantiable<'T>) = i (fun idx -> tyargs.[idx]) // Note, O n looks, but #tyargs is always small + let inst (tyargs: Type list) (i: Instantiable<'T>) = + i (fun idx -> tyargs.[idx]) // Note, O n looks, but #tyargs is always small let bindPropBySearchIfCandidateIsNull (ty: Type) propName retType argTypes candidate = match candidate with @@ -1195,11 +1630,12 @@ module Patterns = ty.GetProperties staticOrInstanceBindingFlags |> Array.filter (fun pi -> let paramTypes = getTypesFromParamInfos (pi.GetIndexParameters()) - pi.Name = propName && - pi.PropertyType = retType && - Array.length argTypes = paramTypes.Length && - Array.forall2 (=) argTypes paramTypes - ) + + pi.Name = propName + && pi.PropertyType = retType + && Array.length argTypes = paramTypes.Length + && Array.forall2 (=) argTypes paramTypes) + match props with | [| pi |] -> pi | _ -> null @@ -1212,9 +1648,10 @@ module Patterns = ty.GetConstructors instanceBindingFlags |> Array.filter (fun ci -> let paramTypes = getTypesFromParamInfos (ci.GetParameters()) - Array.length argTypes = paramTypes.Length && - Array.forall2 (=) argTypes paramTypes - ) + + Array.length argTypes = paramTypes.Length + && Array.forall2 (=) argTypes paramTypes) + match ctors with | [| ctor |] -> ctor | _ -> null @@ -1223,79 +1660,97 @@ module Patterns = let bindProp (genericType, propName, retType, argTypes, tyargs) = // We search in the instantiated type, rather than searching the generic type. let typ = mkNamedType (genericType, tyargs) - let argTypes : Type list = argTypes |> inst tyargs - let retType : Type = retType |> inst tyargs |> removeVoid + let argTypes: Type list = argTypes |> inst tyargs + let retType: Type = retType |> inst tyargs |> removeVoid // fxcop may not see "propName" as an arg typ.GetProperty(propName, staticOrInstanceBindingFlags, null, retType, Array.ofList argTypes, null) |> checkNonNullResult ("propName", String.Format(SR.GetString(SR.QfailedToBindProperty), propName)) let bindField (genericType, fldName, tyargs) = let typ = mkNamedType (genericType, tyargs) + typ.GetField(fldName, staticOrInstanceBindingFlags) |> checkNonNullResult ("fldName", String.Format(SR.GetString(SR.QfailedToBindField), fldName)) // fxcop may not see "fldName" as an arg let bindGenericCctor (genericType: Type) = - genericType.GetConstructor(staticBindingFlags, null, [| |], null) + genericType.GetConstructor(staticBindingFlags, null, [||], null) |> checkNonNullResult ("genericType", SR.GetString(SR.QfailedToBindConstructor)) let bindGenericCtor (genericType: Type, argTypes: Instantiable) = let argTypes = instFormal (getGenericArguments genericType) argTypes + genericType.GetConstructor(instanceBindingFlags, null, Array.ofList argTypes, null) |> checkNonNullResult ("genericType", SR.GetString(SR.QfailedToBindConstructor)) let bindCtor (genericType, argTypes: Instantiable, tyargs) = let typ = mkNamedType (genericType, tyargs) let argTypes = argTypes |> inst tyargs + typ.GetConstructor(instanceBindingFlags, null, Array.ofList argTypes, null) |> checkNonNullResult ("genericType", SR.GetString(SR.QfailedToBindConstructor)) let chop n xs = - if n < 0 then invalidArg "n" (SR.GetString(SR.inputMustBeNonNegative)) + if n < 0 then + invalidArg "n" (SR.GetString(SR.inputMustBeNonNegative)) + let rec split l = match l with | 0, xs -> [], xs | n, x :: xs -> - let front, back = split (n-1, xs) + let front, back = split (n - 1, xs) x :: front, back | _, [] -> failwith "List.chop: not enough elts list" + split (n, xs) let instMeth (ngmeth: MethodInfo, methTypeArgs) = - if ngmeth.GetGenericArguments().Length = 0 then ngmeth(* non generic *) - else ngmeth.MakeGenericMethod(Array.ofList methTypeArgs) + if ngmeth.GetGenericArguments().Length = 0 then + ngmeth (* non generic *) + else + ngmeth.MakeGenericMethod(Array.ofList methTypeArgs) let bindGenericMeth (knownArgCount, (genericType: Type, argTypes, retType, methName, numMethTyargs)) = - bindMethodHelper(knownArgCount, (genericType, methName, numMethTyargs, argTypes, retType)) + bindMethodHelper (knownArgCount, (genericType, methName, numMethTyargs, argTypes, retType)) let bindMeth (knownArgCount, (genericType: Type, argTypes, retType, methName, numMethTyargs), tyargs) = let numEnclTypeArgs = genericType.GetGenericArguments().Length let enclTypeArgs, methTypeArgs = chop numEnclTypeArgs tyargs let ty = mkNamedType (genericType, enclTypeArgs) - let ngmeth = bindMethodHelper(knownArgCount, (ty, methName, numMethTyargs, argTypes, retType)) - instMeth(ngmeth, methTypeArgs) + + let ngmeth = + bindMethodHelper (knownArgCount, (ty, methName, numMethTyargs, argTypes, retType)) + + instMeth (ngmeth, methTypeArgs) let pinfoIsStatic (pinfo: PropertyInfo) = - if pinfo.CanRead then pinfo.GetGetMethod(true).IsStatic - elif pinfo.CanWrite then pinfo.GetSetMethod(true).IsStatic - else false + if pinfo.CanRead then + pinfo.GetGetMethod(true).IsStatic + elif pinfo.CanWrite then + pinfo.GetSetMethod(true).IsStatic + else + false /// Unpickling module SimpleUnpickle = [] type InputState = - { is: ByteStream - istrings: string[] - localAssembly: System.Reflection.Assembly - referencedTypeDefs: Type[] } + { + is: ByteStream + istrings: string[] + localAssembly: System.Reflection.Assembly + referencedTypeDefs: Type[] + } - let u_byte_as_int st = st.is.ReadByte() + let u_byte_as_int st = + st.is.ReadByte() let u_bool st = let b = u_byte_as_int st (b = 1) - let u_void (_: InputState) = () + let u_void (_: InputState) = + () let prim_u_int32 st = let b0 = (u_byte_as_int st) @@ -1306,7 +1761,9 @@ module Patterns = let u_int32 st = let b0 = u_byte_as_int st - if b0 <= 0x7F then b0 + + if b0 <= 0x7F then + b0 elif b0 <= 0xbf then let b0 = b0 &&& 0x7f let b1 = (u_byte_as_int st) @@ -1322,72 +1779,111 @@ module Patterns = let len = u_int32 st st.is.ReadUtf8BytesAsString len - let u_int st = u_int32 st + let u_int st = + u_int32 st - let u_sbyte st = sbyte (u_int32 st) + let u_sbyte st = + sbyte (u_int32 st) - let u_byte st = byte (u_byte_as_int st) + let u_byte st = + byte (u_byte_as_int st) - let u_int16 st = int16 (u_int32 st) + let u_int16 st = + int16 (u_int32 st) - let u_uint16 st = uint16 (u_int32 st) + let u_uint16 st = + uint16 (u_int32 st) - let u_uint32 st = uint32 (u_int32 st) + let u_uint32 st = + uint32 (u_int32 st) let u_int64 st = let b1 = int64 (u_int32 st) &&& 0xFFFFFFFFL let b2 = int64 (u_int32 st) b1 ||| (b2 <<< 32) - let u_uint64 st = uint64 (u_int64 st) + let u_uint64 st = + uint64 (u_int64 st) - let u_double st = System.BitConverter.ToDouble(System.BitConverter.GetBytes(u_int64 st), 0) + let u_double st = + System.BitConverter.ToDouble(System.BitConverter.GetBytes(u_int64 st), 0) - let u_float32 st = System.BitConverter.ToSingle(System.BitConverter.GetBytes(u_int32 st), 0) + let u_float32 st = + System.BitConverter.ToSingle(System.BitConverter.GetBytes(u_int32 st), 0) - let u_char st = char (int32 (u_uint16 st)) + let u_char st = + char (int32 (u_uint16 st)) - let inline u_tup2 p1 p2 st = let a = p1 st in let b = p2 st in (a, b) + let inline u_tup2 p1 p2 st = + let a = p1 st in + let b = p2 st in + (a, b) let inline u_tup3 p1 p2 p3 st = - let a = p1 st in let b = p2 st in let c = p3 st in (a, b, c) + let a = p1 st in + let b = p2 st in + let c = p3 st in + (a, b, c) let inline u_tup4 p1 p2 p3 p4 st = - let a = p1 st in let b = p2 st in let c = p3 st in let d = p4 st in (a, b, c, d) + let a = p1 st in + let b = p2 st in + let c = p3 st in + let d = p4 st in + (a, b, c, d) let inline u_tup5 p1 p2 p3 p4 p5 st = - let a = p1 st in let b = p2 st in let c = p3 st in let d = p4 st in let e = p5 st in (a, b, c, d, e) + let a = p1 st in + let b = p2 st in + let c = p3 st in + let d = p4 st in + let e = p5 st in + (a, b, c, d, e) let u_uniq (tbl: _ array) st = let n = u_int st - if n < 0 || n >= tbl.Length then failwith ("u_uniq: out of range, n = "+string n+ ", sizeof tab = " + string tbl.Length) + + if n < 0 || n >= tbl.Length then + failwith ("u_uniq: out of range, n = " + string n + ", sizeof tab = " + string tbl.Length) + tbl.[n] - let u_string st = u_uniq st.istrings st + let u_string st = + u_uniq st.istrings st let rec u_list_aux f acc st = let tag = u_byte_as_int st + match tag with | 0 -> List.rev acc | 1 -> let a = f st in u_list_aux f (a :: acc) st | n -> failwith ("u_list: found number " + string n) - let u_list f st = u_list_aux f [] st + let u_list f st = + u_list_aux f [] st let unpickleObj localAssembly referencedTypeDefs u phase2bytes = let phase2data = let st2 = - { is = new ByteStream(phase2bytes, 0, phase2bytes.Length) - istrings = [| |] - localAssembly=localAssembly - referencedTypeDefs=referencedTypeDefs } + { + is = new ByteStream(phase2bytes, 0, phase2bytes.Length) + istrings = [||] + localAssembly = localAssembly + referencedTypeDefs = referencedTypeDefs + } + u_tup2 (u_list prim_u_string) u_bytes st2 + let stringTab, phase1bytes = phase2data + let st1 = - { is = new ByteStream(phase1bytes, 0, phase1bytes.Length) - istrings = Array.ofList stringTab - localAssembly=localAssembly - referencedTypeDefs=referencedTypeDefs } + { + is = new ByteStream(phase1bytes, 0, phase1bytes.Length) + istrings = Array.ofList stringTab + localAssembly = localAssembly + referencedTypeDefs = referencedTypeDefs + } + let res = u st1 res @@ -1395,36 +1891,47 @@ module Patterns = let decodeFunTy args = match args with - | [d;r] -> funTyC.MakeGenericType([| d; r |]) + | [ d; r ] -> funTyC.MakeGenericType([| d; r |]) | _ -> invalidArg "args" (SR.GetString(SR.QexpectedTwoTypes)) let decodeArrayTy n (tys: Type list) = match tys with - | [ty] -> if (n = 1) then ty.MakeArrayType() else ty.MakeArrayType n - // typeof.MakeArrayType 1 returns "Int[*]" but we need "Int[]" + | [ ty ] -> + if (n = 1) then + ty.MakeArrayType() + else + ty.MakeArrayType n + // typeof.MakeArrayType 1 returns "Int[*]" but we need "Int[]" | _ -> invalidArg "tys" (SR.GetString(SR.QexpectedOneType)) - let mkNamedTycon (tcName, assembly:Assembly) = + let mkNamedTycon (tcName, assembly: Assembly) = match assembly.GetType tcName with - | null -> + | null -> // For some reason we can get 'null' returned here even when a type with the right name exists... Hence search the slow way... match (assembly.GetTypes() |> Array.tryFind (fun a -> a.FullName = tcName)) with | Some ty -> ty - | None -> invalidArg "tcName" (String.Format(SR.GetString(SR.QfailedToBindTypeInAssembly), tcName, assembly.FullName)) + | None -> + invalidArg + "tcName" + (String.Format(SR.GetString(SR.QfailedToBindTypeInAssembly), tcName, assembly.FullName)) | ty -> ty - let decodeNamedTy genericType tsR = mkNamedType (genericType, tsR) + let decodeNamedTy genericType tsR = + mkNamedType (genericType, tsR) let mscorlib = typeof.Assembly - let u_assemblyRef st = u_string st + let u_assemblyRef st = + u_string st let decodeAssemblyRef st a = - if a = "" then mscorlib - elif a = "." then st.localAssembly + if a = "" then + mscorlib + elif a = "." then + st.localAssembly else match System.Reflection.Assembly.Load a with - | null -> invalidOp(String.Format(SR.GetString(SR.QfailedToBindAssembly), a.ToString())) + | null -> invalidOp (String.Format(SR.GetString(SR.QfailedToBindAssembly), a.ToString())) | assembly -> assembly let u_NamedType st = @@ -1437,12 +1944,15 @@ module Patterns = else // escape commas found in type name, which are not already escaped // '\' is not valid in a type name except as an escape character, so logic can be pretty simple - let escapedTcName = System.Text.RegularExpressions.Regex.Replace(a, @"(? u_void st |> (fun () -> decodeFunTy) | 2 -> u_NamedType st |> decodeNamedTy @@ -1454,62 +1964,84 @@ module Patterns = let rec u_dtype st : (int -> Type) -> Type = let tag = u_byte_as_int st + match tag with - | 0 -> u_int st |> (fun x env -> env x) + | 0 -> u_int st |> (fun x env -> env x) | 1 -> u_tup2 u_tyconstSpec (u_list u_dtype) st |> (fun (a, b) env -> a (appL b env)) | _ -> failwith "u_dtype" - let u_dtypes st = let a = u_list u_dtype st in appL a + let u_dtypes st = + let a = u_list u_dtype st in appL a - let (|NoTyArgs|) input = match input with [] -> () | _ -> failwith "incorrect number of arguments during deserialization" + let (|NoTyArgs|) input = + match input with + | [] -> () + | _ -> failwith "incorrect number of arguments during deserialization" - let (|OneTyArg|) input = match input with [x] -> x | _ -> failwith "incorrect number of arguments during deserialization" + let (|OneTyArg|) input = + match input with + | [ x ] -> x + | _ -> failwith "incorrect number of arguments during deserialization" [] type BindingEnv = - { /// Mapping from variable index to Var object for the variable - vars : Map - /// The number of indexes in the mapping - varn: int - /// The active type instantiation for generic type parameters - typeInst: int -> Type } + { + /// Mapping from variable index to Var object for the variable + vars: Map + /// The number of indexes in the mapping + varn: int + /// The active type instantiation for generic type parameters + typeInst: int -> Type + } let addVar env v = - { env with vars = env.vars.Add(env.varn, v); varn=env.varn+1 } + { env with + vars = env.vars.Add(env.varn, v) + varn = env.varn + 1 + } let mkTyparSubst (tyargs: Type[]) = let n = tyargs.Length + fun idx -> - if idx < n then tyargs.[idx] - else invalidOp (SR.GetString(SR.QtypeArgumentOutOfRange)) + if idx < n then + tyargs.[idx] + else + invalidOp (SR.GetString(SR.QtypeArgumentOutOfRange)) let envClosed (spliceTypes: Type[]) = - { vars = Map.empty - varn = 0 - typeInst = mkTyparSubst spliceTypes } + { + vars = Map.empty + varn = 0 + typeInst = mkTyparSubst spliceTypes + } type Bindable<'T> = BindingEnv -> 'T let rec u_Expr st = let tag = u_byte_as_int st + match tag with | 0 -> let a = u_constSpec st let b = u_dtypes st let args = u_list u_Expr st + (fun (env: BindingEnv) -> let args = List.map (fun e -> e env) args + let a = match a with | Unique v -> v | Ambiguous f -> let argTys = List.map typeOf args f argTys + let tyargs = b env.typeInst - E (CombTerm (a tyargs (ValueSome args.Length), args))) + E(CombTerm(a tyargs (ValueSome args.Length), args))) | 1 -> let x = u_VarRef st - (fun env -> E(VarTerm (x env))) + (fun env -> E(VarTerm(x env))) | 2 -> let a = u_VarDecl st let b = u_Expr st @@ -1520,17 +2052,17 @@ module Patterns = (fun env -> E(HoleTerm(a env.typeInst, idx))) | 4 -> let a = u_Expr st - (fun env -> mkQuote(a env, true)) + (fun env -> mkQuote (a env, true)) | 5 -> let a = u_Expr st let attrs = u_list u_Expr st (fun env -> let e = (a env) in EA(e.Tree, (e.CustomAttributes @ List.map (fun attrf -> attrf env) attrs))) | 6 -> let a = u_dtype st - (fun env -> mkVar(Var.Global("this", a env.typeInst))) + (fun env -> mkVar (Var.Global("this", a env.typeInst))) | 7 -> let a = u_Expr st - (fun env -> mkQuote(a env, false)) + (fun env -> mkQuote (a env, false)) | _ -> failwith "u_Expr" and u_VarDecl st = @@ -1543,49 +2075,53 @@ module Patterns = and u_RecdField st = let ty, nm = u_tup2 u_NamedType u_string st - (fun tyargs -> getRecordProperty(mkNamedType (ty, tyargs), nm)) + (fun tyargs -> getRecordProperty (mkNamedType (ty, tyargs), nm)) and u_UnionCaseInfo st = let ty, nm = u_tup2 u_NamedType u_string st - (fun tyargs -> getUnionCaseInfo(mkNamedType (ty, tyargs), nm)) + (fun tyargs -> getUnionCaseInfo (mkNamedType (ty, tyargs), nm)) and u_UnionCaseField st = let case, i = u_tup2 u_UnionCaseInfo u_int st - (fun tyargs -> getUnionCaseInfoField(case tyargs, i)) + (fun tyargs -> getUnionCaseInfoField (case tyargs, i)) and u_ModuleDefn witnessInfo st = let (ty, nm, isProp) = u_tup3 u_NamedType u_string u_bool st - if isProp then Unique(StaticPropGetOp(bindModuleProperty(ty, nm))) + + if isProp then + Unique(StaticPropGetOp(bindModuleProperty (ty, nm))) else - let meths = ty.GetMethods staticBindingFlags |> Array.filter (fun mi -> mi.Name = nm) - match meths with - | [||] -> - invalidOp (String.Format(SR.GetString(SR.QcannotBindFunction), nm, ty.ToString())) - | [| minfo |] -> - match witnessInfo with - | None -> - Unique(StaticMethodCallOp(minfo)) - | Some (nmW, nWitnesses) -> - let methsW = ty.GetMethods(staticBindingFlags) |> Array.filter (fun mi -> mi.Name = nmW) - match methsW with - | [||] -> - invalidOp (String.Format(SR.GetString(SR.QcannotBindFunction), nmW, ty.ToString())) - | [| minfoW |] -> - Unique(StaticMethodCallWOp(minfo, minfoW, nWitnesses)) - | _ -> - Ambiguous(fun argTypes tyargs -> - let minfoW = bindModuleFunctionWithCallSiteArgs(ty, nm, argTypes, tyargs) - StaticMethodCallWOp(minfo, minfoW, nWitnesses)) - | _ -> - Ambiguous(fun argTypes tyargs -> + let meths = + ty.GetMethods staticBindingFlags |> Array.filter (fun mi -> mi.Name = nm) + + match meths with + | [||] -> invalidOp (String.Format(SR.GetString(SR.QcannotBindFunction), nm, ty.ToString())) + | [| minfo |] -> match witnessInfo with - | None -> - let minfo = bindModuleFunctionWithCallSiteArgs(ty, nm, argTypes, tyargs) - StaticMethodCallOp minfo + | None -> Unique(StaticMethodCallOp(minfo)) | Some (nmW, nWitnesses) -> - let minfo = bindModuleFunctionWithCallSiteArgs(ty, nm, List.skip nWitnesses argTypes, tyargs) - let minfoW = bindModuleFunctionWithCallSiteArgs(ty, nmW, argTypes, tyargs) - StaticMethodCallWOp(minfo, minfoW, nWitnesses)) + let methsW = + ty.GetMethods(staticBindingFlags) |> Array.filter (fun mi -> mi.Name = nmW) + + match methsW with + | [||] -> invalidOp (String.Format(SR.GetString(SR.QcannotBindFunction), nmW, ty.ToString())) + | [| minfoW |] -> Unique(StaticMethodCallWOp(minfo, minfoW, nWitnesses)) + | _ -> + Ambiguous(fun argTypes tyargs -> + let minfoW = bindModuleFunctionWithCallSiteArgs (ty, nm, argTypes, tyargs) + StaticMethodCallWOp(minfo, minfoW, nWitnesses)) + | _ -> + Ambiguous(fun argTypes tyargs -> + match witnessInfo with + | None -> + let minfo = bindModuleFunctionWithCallSiteArgs (ty, nm, argTypes, tyargs) + StaticMethodCallOp minfo + | Some (nmW, nWitnesses) -> + let minfo = + bindModuleFunctionWithCallSiteArgs (ty, nm, List.skip nWitnesses argTypes, tyargs) + + let minfoW = bindModuleFunctionWithCallSiteArgs (ty, nmW, argTypes, tyargs) + StaticMethodCallWOp(minfo, minfoW, nWitnesses)) and u_MethodInfoData st = u_tup5 u_NamedType (u_list u_dtype) u_dtype u_string u_int st @@ -1598,15 +2134,17 @@ module Patterns = and u_MethodBase st = let tag = u_byte_as_int st + match tag with | 0 -> match u_ModuleDefn None st with - | Unique(StaticMethodCallOp minfo) -> (minfo :> MethodBase) - | Unique(StaticPropGetOp pinfo) -> (pinfo.GetGetMethod true :> MethodBase) - | Ambiguous(_) -> raise (System.Reflection.AmbiguousMatchException()) + | Unique (StaticMethodCallOp minfo) -> (minfo :> MethodBase) + | Unique (StaticPropGetOp pinfo) -> (pinfo.GetGetMethod true :> MethodBase) + | Ambiguous (_) -> raise (System.Reflection.AmbiguousMatchException()) | _ -> failwith "unreachable" | 1 -> let ((genericType, _, _, methName, _) as data) = u_MethodInfoData st + if methName = ".cctor" then let cinfo = bindGenericCctor genericType (cinfo :> MethodBase) @@ -1620,98 +2158,152 @@ module Patterns = | 3 -> let methNameW = u_string st let nWitnesses = u_int st - match u_ModuleDefn (Some (methNameW, nWitnesses)) st with - | Unique(StaticMethodCallOp(minfo)) -> (minfo :> MethodBase) - | Unique(StaticMethodCallWOp(_minfo, minfoW, _)) -> (minfoW :> MethodBase) - | Unique(StaticPropGetOp(pinfo)) -> (pinfo.GetGetMethod(true) :> MethodBase) - | Ambiguous(_) -> raise (System.Reflection.AmbiguousMatchException()) + + match u_ModuleDefn (Some(methNameW, nWitnesses)) st with + | Unique (StaticMethodCallOp (minfo)) -> (minfo :> MethodBase) + | Unique (StaticMethodCallWOp (_minfo, minfoW, _)) -> (minfoW :> MethodBase) + | Unique (StaticPropGetOp (pinfo)) -> (pinfo.GetGetMethod(true) :> MethodBase) + | Ambiguous (_) -> raise (System.Reflection.AmbiguousMatchException()) | _ -> failwith "unreachable" | _ -> failwith "u_MethodBase" - and instModuleDefnOp r tyargs _ = match r with - | StaticMethodCallOp(minfo) -> StaticMethodCallOp(instMeth(minfo, tyargs)) - | StaticMethodCallWOp(minfo, minfoW, n) -> StaticMethodCallWOp(instMeth(minfo, tyargs), instMeth(minfoW, tyargs), n) + | StaticMethodCallOp (minfo) -> StaticMethodCallOp(instMeth (minfo, tyargs)) + | StaticMethodCallWOp (minfo, minfoW, n) -> + StaticMethodCallWOp(instMeth (minfo, tyargs), instMeth (minfoW, tyargs), n) // OK to throw away the tyargs here since this only non-generic values in modules get represented by static properties | x -> x and u_constSpec st = let tag = u_byte_as_int st + if tag = 1 then match u_ModuleDefn None st with - | Unique r -> Unique (instModuleDefnOp r) - | Ambiguous f -> Ambiguous (fun argTypes tyargs -> instModuleDefnOp (f argTypes tyargs) tyargs) + | Unique r -> Unique(instModuleDefnOp r) + | Ambiguous f -> Ambiguous(fun argTypes tyargs -> instModuleDefnOp (f argTypes tyargs) tyargs) elif tag = 51 then let nmW = u_string st let nWitnesses = u_int st - match u_ModuleDefn (Some (nmW, nWitnesses)) st with + + match u_ModuleDefn (Some(nmW, nWitnesses)) st with | Unique r -> Unique(instModuleDefnOp r) | Ambiguous f -> Ambiguous(fun argTypes tyargs -> instModuleDefnOp (f argTypes tyargs) tyargs) else - let constSpec = - match tag with - | 0 -> u_void st |> (fun () NoTyArgs _ -> IfThenElseOp) - // 1 taken above - | 2 -> u_void st |> (fun () NoTyArgs _ -> LetRecOp) - | 3 -> u_NamedType st |> (fun x tyargs _ -> NewRecordOp (mkNamedType (x, tyargs))) - | 4 -> u_RecdField st |> (fun prop tyargs _ -> InstancePropGetOp(prop tyargs)) - | 5 -> u_UnionCaseInfo st |> (fun unionCase tyargs _ -> NewUnionCaseOp(unionCase tyargs)) - | 6 -> u_UnionCaseField st |> (fun prop tyargs _ -> InstancePropGetOp(prop tyargs) ) - | 7 -> u_UnionCaseInfo st |> (fun unionCase tyargs _ -> UnionCaseTestOp(unionCase tyargs)) - | 8 -> u_void st |> (fun () (OneTyArg tyarg) _ -> NewTupleOp tyarg) - | 9 -> u_int st |> (fun x (OneTyArg tyarg) _ -> TupleGetOp (tyarg, x)) - // Note, these get type args because they may be the result of reading literal field constants - | 11 -> u_bool st |> (fun x (OneTyArg tyarg) _ -> mkLiftedValueOpG (x, tyarg)) - | 12 -> u_string st |> (fun x (OneTyArg tyarg) _ -> mkLiftedValueOpG (x, tyarg)) - | 13 -> u_float32 st |> (fun x (OneTyArg tyarg) _ -> mkLiftedValueOpG (x, tyarg)) - | 14 -> u_double st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 15 -> u_char st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 16 -> u_sbyte st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 17 -> u_byte st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 18 -> u_int16 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 19 -> u_uint16 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 20 -> u_int32 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 21 -> u_uint32 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 22 -> u_int64 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 23 -> u_uint64 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) - | 24 -> u_void st |> (fun () NoTyArgs _ -> mkLiftedValueOpG ((), typeof)) - | 25 -> u_PropInfoData st |> (fun (a, b, c, d) tyargs _ -> let pinfo = bindProp(a, b, c, d, tyargs) in if pinfoIsStatic pinfo then StaticPropGetOp pinfo else InstancePropGetOp pinfo) - | 26 -> u_CtorInfoData st |> (fun (a, b) tyargs _ -> NewObjectOp (bindCtor(a, b, tyargs))) - | 28 -> u_void st |> (fun () (OneTyArg ty) _ -> CoerceOp ty) - | 29 -> u_void st |> (fun () NoTyArgs _ -> SequentialOp) - | 30 -> u_void st |> (fun () NoTyArgs _ -> ForIntegerRangeLoopOp) - | 31 -> u_MethodInfoData st |> (fun p tyargs knownArgCount -> let minfo = bindMeth(knownArgCount, p, tyargs) in if minfo.IsStatic then StaticMethodCallOp minfo else InstanceMethodCallOp minfo) - | 32 -> u_void st |> (fun () (OneTyArg ty) _ -> NewArrayOp ty) - | 33 -> u_void st |> (fun () (OneTyArg ty) _ -> NewDelegateOp ty) - | 34 -> u_void st |> (fun () NoTyArgs _ -> WhileLoopOp) - | 35 -> u_void st |> (fun () NoTyArgs _ -> LetOp) - | 36 -> u_RecdField st |> (fun prop tyargs _ -> InstancePropSetOp(prop tyargs)) - | 37 -> u_tup2 u_NamedType u_string st |> (fun (a, b) tyargs _ -> let finfo = bindField(a, b, tyargs) in if finfo.IsStatic then StaticFieldGetOp finfo else InstanceFieldGetOp finfo) - | 38 -> u_void st |> (fun () NoTyArgs _ -> LetRecCombOp) - | 39 -> u_void st |> (fun () NoTyArgs _ -> AppOp) - | 40 -> u_void st |> (fun () (OneTyArg ty) _ -> ValueOp(null, ty, None)) - | 41 -> u_void st |> (fun () (OneTyArg ty) _ -> DefaultValueOp ty) - | 42 -> u_PropInfoData st |> (fun (a, b, c, d) tyargs _ -> let pinfo = bindProp(a, b, c, d, tyargs) in if pinfoIsStatic pinfo then StaticPropSetOp pinfo else InstancePropSetOp pinfo) - | 43 -> u_tup2 u_NamedType u_string st |> (fun (a, b) tyargs _ -> let finfo = bindField(a, b, tyargs) in if finfo.IsStatic then StaticFieldSetOp finfo else InstanceFieldSetOp finfo) - | 44 -> u_void st |> (fun () NoTyArgs _ -> AddressOfOp) - | 45 -> u_void st |> (fun () NoTyArgs _ -> AddressSetOp) - | 46 -> u_void st |> (fun () (OneTyArg ty) _ -> TypeTestOp ty) - | 47 -> u_void st |> (fun () NoTyArgs _ -> TryFinallyOp) - | 48 -> u_void st |> (fun () NoTyArgs _ -> TryWithOp) - | 49 -> u_void st |> (fun () NoTyArgs _ -> VarSetOp) - | 50 -> - let m1 = u_MethodInfoData st - let m2 = u_MethodInfoData st - let n = u_int st - (fun tyargs _ -> - let minfo = bindMeth (ValueNone, m1, tyargs) - let minfoW = bindMeth (ValueNone, m2, tyargs) - if minfo.IsStatic then StaticMethodCallWOp(minfo, minfoW, n) - else InstanceMethodCallWOp(minfo, minfoW, n)) - // 51 taken above - | _ -> failwith ("u_constSpec, unrecognized tag " + string tag) - Unique constSpec + let constSpec = + match tag with + | 0 -> u_void st |> (fun () NoTyArgs _ -> IfThenElseOp) + // 1 taken above + | 2 -> u_void st |> (fun () NoTyArgs _ -> LetRecOp) + | 3 -> u_NamedType st |> (fun x tyargs _ -> NewRecordOp(mkNamedType (x, tyargs))) + | 4 -> u_RecdField st |> (fun prop tyargs _ -> InstancePropGetOp(prop tyargs)) + | 5 -> + u_UnionCaseInfo st + |> (fun unionCase tyargs _ -> NewUnionCaseOp(unionCase tyargs)) + | 6 -> u_UnionCaseField st |> (fun prop tyargs _ -> InstancePropGetOp(prop tyargs)) + | 7 -> + u_UnionCaseInfo st + |> (fun unionCase tyargs _ -> UnionCaseTestOp(unionCase tyargs)) + | 8 -> u_void st |> (fun () (OneTyArg tyarg) _ -> NewTupleOp tyarg) + | 9 -> u_int st |> (fun x (OneTyArg tyarg) _ -> TupleGetOp(tyarg, x)) + // Note, these get type args because they may be the result of reading literal field constants + | 11 -> u_bool st |> (fun x (OneTyArg tyarg) _ -> mkLiftedValueOpG (x, tyarg)) + | 12 -> u_string st |> (fun x (OneTyArg tyarg) _ -> mkLiftedValueOpG (x, tyarg)) + | 13 -> u_float32 st |> (fun x (OneTyArg tyarg) _ -> mkLiftedValueOpG (x, tyarg)) + | 14 -> u_double st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 15 -> u_char st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 16 -> u_sbyte st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 17 -> u_byte st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 18 -> u_int16 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 19 -> u_uint16 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 20 -> u_int32 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 21 -> u_uint32 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 22 -> u_int64 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 23 -> u_uint64 st |> (fun a (OneTyArg tyarg) _ -> mkLiftedValueOpG (a, tyarg)) + | 24 -> u_void st |> (fun () NoTyArgs _ -> mkLiftedValueOpG ((), typeof)) + | 25 -> + u_PropInfoData st + |> (fun (a, b, c, d) tyargs _ -> + let pinfo = bindProp (a, b, c, d, tyargs) in + + if pinfoIsStatic pinfo then + StaticPropGetOp pinfo + else + InstancePropGetOp pinfo) + | 26 -> + u_CtorInfoData st + |> (fun (a, b) tyargs _ -> NewObjectOp(bindCtor (a, b, tyargs))) + | 28 -> u_void st |> (fun () (OneTyArg ty) _ -> CoerceOp ty) + | 29 -> u_void st |> (fun () NoTyArgs _ -> SequentialOp) + | 30 -> u_void st |> (fun () NoTyArgs _ -> ForIntegerRangeLoopOp) + | 31 -> + u_MethodInfoData st + |> (fun p tyargs knownArgCount -> + let minfo = bindMeth (knownArgCount, p, tyargs) in + + if minfo.IsStatic then + StaticMethodCallOp minfo + else + InstanceMethodCallOp minfo) + | 32 -> u_void st |> (fun () (OneTyArg ty) _ -> NewArrayOp ty) + | 33 -> u_void st |> (fun () (OneTyArg ty) _ -> NewDelegateOp ty) + | 34 -> u_void st |> (fun () NoTyArgs _ -> WhileLoopOp) + | 35 -> u_void st |> (fun () NoTyArgs _ -> LetOp) + | 36 -> u_RecdField st |> (fun prop tyargs _ -> InstancePropSetOp(prop tyargs)) + | 37 -> + u_tup2 u_NamedType u_string st + |> (fun (a, b) tyargs _ -> + let finfo = bindField (a, b, tyargs) in + + if finfo.IsStatic then + StaticFieldGetOp finfo + else + InstanceFieldGetOp finfo) + | 38 -> u_void st |> (fun () NoTyArgs _ -> LetRecCombOp) + | 39 -> u_void st |> (fun () NoTyArgs _ -> AppOp) + | 40 -> u_void st |> (fun () (OneTyArg ty) _ -> ValueOp(null, ty, None)) + | 41 -> u_void st |> (fun () (OneTyArg ty) _ -> DefaultValueOp ty) + | 42 -> + u_PropInfoData st + |> (fun (a, b, c, d) tyargs _ -> + let pinfo = bindProp (a, b, c, d, tyargs) in + + if pinfoIsStatic pinfo then + StaticPropSetOp pinfo + else + InstancePropSetOp pinfo) + | 43 -> + u_tup2 u_NamedType u_string st + |> (fun (a, b) tyargs _ -> + let finfo = bindField (a, b, tyargs) in + + if finfo.IsStatic then + StaticFieldSetOp finfo + else + InstanceFieldSetOp finfo) + | 44 -> u_void st |> (fun () NoTyArgs _ -> AddressOfOp) + | 45 -> u_void st |> (fun () NoTyArgs _ -> AddressSetOp) + | 46 -> u_void st |> (fun () (OneTyArg ty) _ -> TypeTestOp ty) + | 47 -> u_void st |> (fun () NoTyArgs _ -> TryFinallyOp) + | 48 -> u_void st |> (fun () NoTyArgs _ -> TryWithOp) + | 49 -> u_void st |> (fun () NoTyArgs _ -> VarSetOp) + | 50 -> + let m1 = u_MethodInfoData st + let m2 = u_MethodInfoData st + let n = u_int st + + (fun tyargs _ -> + let minfo = bindMeth (ValueNone, m1, tyargs) + let minfoW = bindMeth (ValueNone, m2, tyargs) + + if minfo.IsStatic then + StaticMethodCallWOp(minfo, minfoW, n) + else + InstanceMethodCallWOp(minfo, minfoW, n)) + // 51 taken above + | _ -> failwith ("u_constSpec, unrecognized tag " + string tag) + + Unique constSpec let u_ReflectedDefinition = u_tup2 u_MethodBase u_Expr @@ -1732,29 +2324,46 @@ module Patterns = let rec fillHolesInRawExpr (l: Expr[]) (E t as e) = match t with | VarTerm _ -> e - | LambdaTerm (v, b) -> EA(LambdaTerm(v, fillHolesInRawExpr l b ), e.CustomAttributes) - | CombTerm (op, args) -> EA(CombTerm(op, args |> List.map (fillHolesInRawExpr l)), e.CustomAttributes) - | HoleTerm (ty, idx) -> - if idx < 0 || idx >= l.Length then failwith "hole index out of range" - let h = l.[idx] - match typeOf h with - | expected when expected <> ty -> invalidArg "receivedType" (String.Format(SR.GetString(SR.QtmmRaw), expected, ty)) - | _ -> h + | LambdaTerm (v, b) -> EA(LambdaTerm(v, fillHolesInRawExpr l b), e.CustomAttributes) + | CombTerm (op, args) -> EA(CombTerm(op, args |> List.map (fillHolesInRawExpr l)), e.CustomAttributes) + | HoleTerm (ty, idx) -> + if idx < 0 || idx >= l.Length then + failwith "hole index out of range" + + let h = l.[idx] + + match typeOf h with + | expected when expected <> ty -> + invalidArg "receivedType" (String.Format(SR.GetString(SR.QtmmRaw), expected, ty)) + | _ -> h let rec freeInExprAcc bvs acc (E t) = match t with - | HoleTerm _ -> acc + | HoleTerm _ -> acc | CombTerm (_, ag) -> ag |> List.fold (freeInExprAcc bvs) acc - | VarTerm v -> if Set.contains v bvs || Set.contains v acc then acc else Set.add v acc + | VarTerm v -> + if Set.contains v bvs || Set.contains v acc then + acc + else + Set.add v acc | LambdaTerm (v, b) -> freeInExprAcc (Set.add v bvs) acc b - and freeInExpr e = freeInExprAcc Set.empty Set.empty e + + and freeInExpr e = + freeInExprAcc Set.empty Set.empty e // utility for folding let foldWhile f st (ie: seq<'T>) = use e = ie.GetEnumerator() let mutable res = Some st + while (res.IsSome && e.MoveNext()) do - res <- f (match res with Some a -> a | _ -> failwith "internal error") e.Current + res <- + f + (match res with + | Some a -> a + | _ -> failwith "internal error") + e.Current + res [] @@ -1767,304 +2376,375 @@ module Patterns = | CombTerm (c, args) -> let substargs = args |> List.map (fun arg -> substituteInExpr bvs tmsubst arg) EA(CombTerm(c, substargs), e.CustomAttributes) - | VarTerm v -> + | VarTerm v -> match tmsubst v with | None -> e | Some e2 -> let fvs = freeInExpr e2 let clashes = Set.intersect fvs bvs in - if clashes.IsEmpty then e2 - else raise (Clash(clashes.MinimumElement)) + + if clashes.IsEmpty then + e2 + else + raise (Clash(clashes.MinimumElement)) | LambdaTerm (v, b) -> - try EA(LambdaTerm(v, substituteInExpr (Set.add v bvs) tmsubst b), e.CustomAttributes) - with Clash bv -> - if v = bv then - let v2 = new Var(v.Name, v.Type) - let v2exp = E(VarTerm v2) - EA(LambdaTerm(v2, substituteInExpr bvs (fun v -> if v = bv then Some v2exp else tmsubst v) b), e.CustomAttributes) - else - reraise() + try + EA(LambdaTerm(v, substituteInExpr (Set.add v bvs) tmsubst b), e.CustomAttributes) + with Clash bv -> + if v = bv then + let v2 = new Var(v.Name, v.Type) + let v2exp = E(VarTerm v2) + let b2 = substituteInExpr bvs (fun v -> if v = bv then Some v2exp else tmsubst v) b + EA(LambdaTerm(v2, b2), e.CustomAttributes) + else + reraise () | HoleTerm _ -> e + let substituteRaw tmsubst e = + substituteInExpr Set.empty tmsubst e - let substituteRaw tmsubst e = substituteInExpr Set.empty tmsubst e - - let readToEnd (s : Stream) = + let readToEnd (s: Stream) = let n = int s.Length let res = Array.zeroCreate n let mutable i = 0 + while (i < n) do - i <- i + s.Read(res, i, (n - i)) + i <- i + s.Read(res, i, (n - i)) + res - let decodedTopResources = new Dictionary(10, HashIdentity.Structural) + let decodedTopResources = + new Dictionary(10, HashIdentity.Structural) [] type ReflectedDefinitionTableKey = | Key of ModuleHandle * int + static member GetKey(methodBase: MethodBase) = Key(methodBase.Module.ModuleHandle, methodBase.MetadataToken) [] type ReflectedDefinitionTableEntry = Entry of Bindable - let reflectedDefinitionTable = new Dictionary(10, HashIdentity.Structural) + let reflectedDefinitionTable = + new Dictionary(10, HashIdentity.Structural) let registerReflectedDefinitions (assem, resourceName, bytes, referencedTypes) = let defns = unpickleReflectedDefns assem referencedTypes bytes - defns |> List.iter (fun (minfo, exprBuilder) -> + + defns + |> List.iter (fun (minfo, exprBuilder) -> let key = ReflectedDefinitionTableKey.GetKey minfo - lock reflectedDefinitionTable (fun () -> - reflectedDefinitionTable.Add(key, Entry exprBuilder))) + lock reflectedDefinitionTable (fun () -> reflectedDefinitionTable.Add(key, Entry exprBuilder))) + decodedTopResources.Add((assem, resourceName), 0) + let isReflectedDefinitionResourceName (resourceName: string) = + resourceName.StartsWith(ReflectedDefinitionsResourceNameBase, StringComparison.Ordinal) + /// Get the reflected definition at the given (always generic) instantiation - let tryGetReflectedDefinition (methodBase: MethodBase, tyargs: Type []) = + let tryGetReflectedDefinition (methodBase: MethodBase, tyargs: Type[]) = checkNonNull "methodBase" methodBase + let data = - let assem = methodBase.DeclaringType.Assembly - let key = ReflectedDefinitionTableKey.GetKey methodBase - let ok, res = lock reflectedDefinitionTable (fun () -> reflectedDefinitionTable.TryGetValue key) - - if ok then Some res else - - let qdataResources = - // dynamic assemblies don't support the GetManifestResourceNames - match assem with - | a when a.FullName = "System.Reflection.Emit.AssemblyBuilder" -> [] - | null | _ -> - let resources = - // This raises NotSupportedException for dynamic assemblies - try assem.GetManifestResourceNames() - with :? NotSupportedException -> [| |] - [ for resourceName in resources do - if resourceName.StartsWith(ReflectedDefinitionsResourceNameBase, StringComparison.Ordinal) && - not (decodedTopResources.ContainsKey((assem, resourceName))) then - - let cmaAttribForResource = - assem.GetCustomAttributes(typeof, false) - |> (function null -> [| |] | x -> x) - |> Array.tryPick (fun ca -> - match ca with - | :? CompilationMappingAttribute as cma when cma.ResourceName = resourceName -> Some cma - | _ -> None) - let resourceBytes = readToEnd (assem.GetManifestResourceStream resourceName) - let referencedTypes = - match cmaAttribForResource with - | None -> [| |] - | Some cma -> cma.TypeDefinitions - yield (resourceName, unpickleReflectedDefns assem referencedTypes resourceBytes) ] - - // ok, add to the table + let assem = methodBase.DeclaringType.Assembly + let key = ReflectedDefinitionTableKey.GetKey methodBase + let ok, res = - lock reflectedDefinitionTable (fun () -> - // check another thread didn't get in first - if not (reflectedDefinitionTable.ContainsKey key) then - qdataResources - |> List.iter (fun (resourceName, defns) -> - defns |> List.iter (fun (methodBase, exprBuilder) -> - reflectedDefinitionTable.[ReflectedDefinitionTableKey.GetKey methodBase] <- Entry exprBuilder) - decodedTopResources.[(assem, resourceName)] <- 0) - // we know it's in the table now, if it's ever going to be there - reflectedDefinitionTable.TryGetValue key - ) - - if ok then Some res else None + lock reflectedDefinitionTable (fun () -> reflectedDefinitionTable.TryGetValue key) + + if ok then + Some res + else + + let qdataResources = + // dynamic assemblies don't support the GetManifestResourceNames + match assem with + | a when a.FullName = "System.Reflection.Emit.AssemblyBuilder" -> [] + | null + | _ -> + let resources = + // This raises NotSupportedException for dynamic assemblies + try + assem.GetManifestResourceNames() + with :? NotSupportedException -> + [||] + + [ + for resourceName in resources do + if + isReflectedDefinitionResourceName resourceName + && not (decodedTopResources.ContainsKey((assem, resourceName))) + then + + let cmaAttribForResource = + assem.GetCustomAttributes(typeof, false) + |> (function + | null -> [||] + | x -> x) + |> Array.tryPick (fun ca -> + match ca with + | :? CompilationMappingAttribute as cma when cma.ResourceName = resourceName -> + Some cma + | _ -> None) + + let resourceBytes = readToEnd (assem.GetManifestResourceStream resourceName) + + let referencedTypes = + match cmaAttribForResource with + | None -> [||] + | Some cma -> cma.TypeDefinitions + + yield (resourceName, unpickleReflectedDefns assem referencedTypes resourceBytes) + ] + + // ok, add to the table + let ok, res = + lock reflectedDefinitionTable (fun () -> + // check another thread didn't get in first + if not (reflectedDefinitionTable.ContainsKey key) then + qdataResources + |> List.iter (fun (resourceName, defns) -> + defns + |> List.iter (fun (methodBase, exprBuilder) -> + reflectedDefinitionTable.[ReflectedDefinitionTableKey.GetKey methodBase] <- + Entry exprBuilder) + + decodedTopResources.[(assem, resourceName)] <- 0) + // we know it's in the table now, if it's ever going to be there + reflectedDefinitionTable.TryGetValue key) + + if ok then Some res else None match data with | Some (Entry exprBuilder) -> let expectedNumTypars = - getNumGenericArguments(methodBase.DeclaringType) + - (match methodBase with - | :? MethodInfo as minfo -> if minfo.IsGenericMethod then minfo.GetGenericArguments().Length else 0 - | _ -> 0) + getNumGenericArguments (methodBase.DeclaringType) + + (match methodBase with + | :? MethodInfo as minfo -> + if minfo.IsGenericMethod then + minfo.GetGenericArguments().Length + else + 0 + | _ -> 0) + if (expectedNumTypars <> tyargs.Length) then - invalidArg "tyargs" (String.Format(SR.GetString(SR.QwrongNumOfTypeArgs), methodBase.Name, expectedNumTypars.ToString(), tyargs.Length.ToString())) + invalidArg + "tyargs" + (String.Format( + SR.GetString(SR.QwrongNumOfTypeArgs), + methodBase.Name, + expectedNumTypars.ToString(), + tyargs.Length.ToString() + )) + Some(exprBuilder (envClosed tyargs)) | None -> None /// Get the reflected definition at the generic instantiation let tryGetReflectedDefinitionInstantiated (methodBase: MethodBase) = checkNonNull "methodBase" methodBase + match methodBase with | :? MethodInfo as minfo -> - let tyargs = - Array.append - (getGenericArguments minfo.DeclaringType) - (if minfo.IsGenericMethod then minfo.GetGenericArguments() else [| |]) - tryGetReflectedDefinition (methodBase, tyargs) + let tyargs = + Array.append + (getGenericArguments minfo.DeclaringType) + (if minfo.IsGenericMethod then + minfo.GetGenericArguments() + else + [||]) + + tryGetReflectedDefinition (methodBase, tyargs) | :? ConstructorInfo as cinfo -> - let tyargs = getGenericArguments cinfo.DeclaringType - tryGetReflectedDefinition (methodBase, tyargs) - | _ -> - tryGetReflectedDefinition (methodBase, [| |]) + let tyargs = getGenericArguments cinfo.DeclaringType + tryGetReflectedDefinition (methodBase, tyargs) + | _ -> tryGetReflectedDefinition (methodBase, [||]) let deserialize (localAssembly, referencedTypeDefs, spliceTypes, spliceExprs, bytes) : Expr = - let expr = unpickleExpr localAssembly referencedTypeDefs bytes (envClosed spliceTypes) - fillHolesInRawExpr spliceExprs expr + let expr = + unpickleExpr localAssembly referencedTypeDefs bytes (envClosed spliceTypes) + fillHolesInRawExpr spliceExprs expr let cast (expr: Expr) : Expr<'T> = - checkTypesSR (typeof<'T>) (typeOf expr) "expr" (SR.GetString(SR.QtmmExprHasWrongType)) + checkTypesSR (typeof<'T>) (typeOf expr) "expr" (SR.GetString(SR.QtmmExprHasWrongType)) new Expr<'T>(expr.Tree, expr.CustomAttributes) open Patterns - type Expr with - member x.Substitute substitution = substituteRaw substitution x - member x.GetFreeVars () = (freeInExpr x :> seq<_>) + + member x.Substitute substitution = + substituteRaw substitution x + + member x.GetFreeVars() = + (freeInExpr x :> seq<_>) + member x.Type = typeOf x - static member AddressOf (target: Expr) = + static member AddressOf(target: Expr) = mkAddressOf target - static member AddressSet (target: Expr, value: Expr) = + static member AddressSet(target: Expr, value: Expr) = mkAddressSet (target, value) - static member Application (functionExpr: Expr, argument: Expr) = + static member Application(functionExpr: Expr, argument: Expr) = mkApplication (functionExpr, argument) - static member Applications (functionExpr: Expr, arguments) = + static member Applications(functionExpr: Expr, arguments) = mkApplications (functionExpr, arguments) - static member Call (methodInfo:MethodInfo, arguments) = + static member Call(methodInfo: MethodInfo, arguments) = checkNonNull "methodInfo" methodInfo mkStaticMethodCall (methodInfo, arguments) - static member Call (obj: Expr, methodInfo:MethodInfo, arguments) = + static member Call(obj: Expr, methodInfo: MethodInfo, arguments) = checkNonNull "methodInfo" methodInfo mkInstanceMethodCall (obj, methodInfo, arguments) - static member CallWithWitnesses (methodInfo: MethodInfo, methodInfoWithWitnesses: MethodInfo, witnesses, arguments) = + static member CallWithWitnesses(methodInfo: MethodInfo, methodInfoWithWitnesses: MethodInfo, witnesses, arguments) = checkNonNull "methodInfo" methodInfo checkNonNull "methodInfoWithWitnesses" methodInfoWithWitnesses - mkStaticMethodCallW (methodInfo, methodInfoWithWitnesses, List.length witnesses, witnesses@arguments) - - static member CallWithWitnesses (obj: Expr, methodInfo: MethodInfo, methodInfoWithWitnesses: MethodInfo, witnesses, arguments) = + mkStaticMethodCallW (methodInfo, methodInfoWithWitnesses, List.length witnesses, witnesses @ arguments) + + static member CallWithWitnesses + ( + obj: Expr, + methodInfo: MethodInfo, + methodInfoWithWitnesses: MethodInfo, + witnesses, + arguments + ) = checkNonNull "methodInfo" methodInfo checkNonNull "methodInfoWithWitnesses" methodInfoWithWitnesses - mkInstanceMethodCallW (obj, methodInfo, methodInfoWithWitnesses, List.length witnesses, witnesses@arguments) + mkInstanceMethodCallW (obj, methodInfo, methodInfoWithWitnesses, List.length witnesses, witnesses @ arguments) - static member Coerce (source: Expr, target: Type) = + static member Coerce(source: Expr, target: Type) = checkNonNull "target" target mkCoerce (target, source) - static member IfThenElse (guard: Expr, thenExpr: Expr, elseExpr: Expr) = + static member IfThenElse(guard: Expr, thenExpr: Expr, elseExpr: Expr) = mkIfThenElse (guard, thenExpr, elseExpr) - static member ForIntegerRangeLoop (loopVariable, start: Expr, endExpr: Expr, body: Expr) = - mkForLoop(loopVariable, start, endExpr, body) + static member ForIntegerRangeLoop(loopVariable, start: Expr, endExpr: Expr, body: Expr) = + mkForLoop (loopVariable, start, endExpr, body) - static member FieldGet (fieldInfo:FieldInfo) = + static member FieldGet(fieldInfo: FieldInfo) = checkNonNull "fieldInfo" fieldInfo mkStaticFieldGet fieldInfo - static member FieldGet (obj: Expr, fieldInfo:FieldInfo) = + static member FieldGet(obj: Expr, fieldInfo: FieldInfo) = checkNonNull "fieldInfo" fieldInfo mkInstanceFieldGet (obj, fieldInfo) - static member FieldSet (fieldInfo:FieldInfo, value: Expr) = + static member FieldSet(fieldInfo: FieldInfo, value: Expr) = checkNonNull "fieldInfo" fieldInfo mkStaticFieldSet (fieldInfo, value) - static member FieldSet (obj: Expr, fieldInfo:FieldInfo, value: Expr) = + static member FieldSet(obj: Expr, fieldInfo: FieldInfo, value: Expr) = checkNonNull "fieldInfo" fieldInfo mkInstanceFieldSet (obj, fieldInfo, value) - static member Lambda (parameter: Var, body: Expr) = mkLambda (parameter, body) + static member Lambda(parameter: Var, body: Expr) = + mkLambda (parameter, body) - static member Let (letVariable: Var, letExpr: Expr, body: Expr) = mkLet (letVariable, letExpr, body) + static member Let(letVariable: Var, letExpr: Expr, body: Expr) = + mkLet (letVariable, letExpr, body) - static member LetRecursive (bindings, body: Expr) = mkLetRec (bindings, body) + static member LetRecursive(bindings, body: Expr) = + mkLetRec (bindings, body) - static member NewObject (constructorInfo:ConstructorInfo, arguments) = + static member NewObject(constructorInfo: ConstructorInfo, arguments) = checkNonNull "constructorInfo" constructorInfo mkCtorCall (constructorInfo, arguments) - static member DefaultValue (expressionType: Type) = + static member DefaultValue(expressionType: Type) = checkNonNull "expressionType" expressionType mkDefaultValue expressionType static member NewTuple elements = mkNewTuple elements - static member NewStructTuple (asm:Assembly, elements) = + static member NewStructTuple(asm: Assembly, elements) = mkNewStructTuple (asm, elements) - static member NewRecord (recordType: Type, elements) = + static member NewRecord(recordType: Type, elements) = checkNonNull "recordType" recordType mkNewRecord (recordType, elements) - static member NewArray (elementType: Type, elements) = + static member NewArray(elementType: Type, elements) = checkNonNull "elementType" elementType - mkNewArray(elementType, elements) + mkNewArray (elementType, elements) - static member NewDelegate (delegateType: Type, parameters: Var list, body: Expr) = + static member NewDelegate(delegateType: Type, parameters: Var list, body: Expr) = checkNonNull "delegateType" delegateType - mkNewDelegate(delegateType, mkIteratedLambdas (parameters, body)) + mkNewDelegate (delegateType, mkIteratedLambdas (parameters, body)) - static member NewUnionCase (unionCase, arguments) = + static member NewUnionCase(unionCase, arguments) = mkNewUnionCase (unionCase, arguments) - static member PropertyGet (obj: Expr, property: PropertyInfo, ?indexerArgs) = + static member PropertyGet(obj: Expr, property: PropertyInfo, ?indexerArgs) = checkNonNull "property" property mkInstancePropGet (obj, property, defaultArg indexerArgs []) - static member PropertyGet (property: PropertyInfo, ?indexerArgs) = + static member PropertyGet(property: PropertyInfo, ?indexerArgs) = checkNonNull "property" property mkStaticPropGet (property, defaultArg indexerArgs []) - static member PropertySet (obj: Expr, property: PropertyInfo, value: Expr, ?indexerArgs) = + static member PropertySet(obj: Expr, property: PropertyInfo, value: Expr, ?indexerArgs) = checkNonNull "property" property - mkInstancePropSet(obj, property, defaultArg indexerArgs [], value) + mkInstancePropSet (obj, property, defaultArg indexerArgs [], value) - static member PropertySet (property: PropertyInfo, value: Expr, ?indexerArgs) = - mkStaticPropSet(property, defaultArg indexerArgs [], value) + static member PropertySet(property: PropertyInfo, value: Expr, ?indexerArgs) = + mkStaticPropSet (property, defaultArg indexerArgs [], value) - static member Quote (inner: Expr) = mkQuote (inner, true) + static member Quote(inner: Expr) = + mkQuote (inner, true) - static member QuoteRaw (inner: Expr) = mkQuote (inner, false) + static member QuoteRaw(inner: Expr) = + mkQuote (inner, false) - static member QuoteTyped (inner: Expr) = mkQuote (inner, true) + static member QuoteTyped(inner: Expr) = + mkQuote (inner, true) - static member Sequential (first: Expr, second: Expr) = + static member Sequential(first: Expr, second: Expr) = mkSequential (first, second) - static member TryWith (body: Expr, filterVar: Var, filterBody: Expr, catchVar: Var, catchBody: Expr) = + static member TryWith(body: Expr, filterVar: Var, filterBody: Expr, catchVar: Var, catchBody: Expr) = mkTryWith (body, filterVar, filterBody, catchVar, catchBody) - static member TryFinally (body: Expr, compensation: Expr) = + static member TryFinally(body: Expr, compensation: Expr) = mkTryFinally (body, compensation) - static member TupleGet (tuple: Expr, index: int) = + static member TupleGet(tuple: Expr, index: int) = mkTupleGet (typeOf tuple, index, tuple) - static member TypeTest (source: Expr, target: Type) = + static member TypeTest(source: Expr, target: Type) = checkNonNull "target" target mkTypeTest (source, target) - static member UnionCaseTest (source: Expr, unionCase: UnionCaseInfo) = + static member UnionCaseTest(source: Expr, unionCase: UnionCaseInfo) = mkUnionCaseTest (unionCase, source) - static member Value (value: 'T) = + static member Value(value: 'T) = mkValue (box value, typeof<'T>) static member Value(value: obj, expressionType: Type) = checkNonNull "expressionType" expressionType - mkValue(value, expressionType) + mkValue (value, expressionType) - static member ValueWithName (value: 'T, name:string) = + static member ValueWithName(value: 'T, name: string) = checkNonNull "name" name mkValueWithName (box value, typeof<'T>, name) - static member ValueWithName(value: obj, expressionType: Type, name:string) = + static member ValueWithName(value: obj, expressionType: Type, name: string) = checkNonNull "expressionType" expressionType checkNonNull "name" name - mkValueWithName(value, expressionType, name) + mkValueWithName (value, expressionType, name) - static member WithValue (value: 'T, definition: Expr<'T>) = - let raw = mkValueWithDefn(box value, typeof<'T>, definition) + static member WithValue(value: 'T, definition: Expr<'T>) = + let raw = mkValueWithDefn (box value, typeof<'T>, definition) new Expr<'T>(raw.Tree, raw.CustomAttributes) static member WithValue(value: obj, expressionType: Type, definition: Expr) = @@ -2074,22 +2754,23 @@ type Expr with static member Var variable = mkVar variable - static member VarSet (variable, value: Expr) = + static member VarSet(variable, value: Expr) = mkVarSet (variable, value) - static member WhileLoop (guard: Expr, body: Expr) = + static member WhileLoop(guard: Expr, body: Expr) = mkWhileLoop (guard, body) static member TryGetReflectedDefinition(methodBase: MethodBase) = checkNonNull "methodBase" methodBase tryGetReflectedDefinitionInstantiated methodBase - static member Cast(source: Expr) = cast source + static member Cast(source: Expr) = + cast source static member Deserialize(qualifyingType: Type, spliceTypes, spliceExprs, bytes: byte[]) = checkNonNull "qualifyingType" qualifyingType checkNonNull "bytes" bytes - deserialize (qualifyingType, [| |], Array.ofList spliceTypes, Array.ofList spliceExprs, bytes) + deserialize (qualifyingType, [||], Array.ofList spliceTypes, Array.ofList spliceExprs, bytes) static member Deserialize40(qualifyingType: Type, referencedTypes, spliceTypes, spliceExprs, bytes: byte[]) = checkNonNull "spliceExprs" spliceExprs @@ -2100,61 +2781,103 @@ type Expr with deserialize (qualifyingType, referencedTypes, spliceTypes, spliceExprs, bytes) static member RegisterReflectedDefinitions(assembly, resource, serializedValue) = - Expr.RegisterReflectedDefinitions (assembly, resource, serializedValue, [| |]) + Expr.RegisterReflectedDefinitions(assembly, resource, serializedValue, [||]) static member RegisterReflectedDefinitions(assembly, resource, serializedValue, referencedTypes) = checkNonNull "assembly" assembly - registerReflectedDefinitions(assembly, resource, serializedValue, referencedTypes) + registerReflectedDefinitions (assembly, resource, serializedValue, referencedTypes) static member GlobalVar<'T>(name) : Expr<'T> = checkNonNull "name" name - Expr.Var (Var.Global(name, typeof<'T>)) |> Expr.Cast + Expr.Var(Var.Global(name, typeof<'T>)) |> Expr.Cast [] module DerivedPatterns = open Patterns [] - let (|Bool|_|) input = match input with ValueObj(:? bool as v) -> Some v | _ -> None + let (|Bool|_|) input = + match input with + | ValueObj (:? bool as v) -> Some v + | _ -> None [] - let (|String|_|) input = match input with ValueObj(:? string as v) -> Some v | _ -> None + let (|String|_|) input = + match input with + | ValueObj (:? string as v) -> Some v + | _ -> None [] - let (|Single|_|) input = match input with ValueObj(:? single as v) -> Some v | _ -> None + let (|Single|_|) input = + match input with + | ValueObj (:? single as v) -> Some v + | _ -> None [] - let (|Double|_|) input = match input with ValueObj(:? double as v) -> Some v | _ -> None + let (|Double|_|) input = + match input with + | ValueObj (:? double as v) -> Some v + | _ -> None [] - let (|Char|_|) input = match input with ValueObj(:? char as v) -> Some v | _ -> None + let (|Char|_|) input = + match input with + | ValueObj (:? char as v) -> Some v + | _ -> None [] - let (|SByte|_|) input = match input with ValueObj(:? sbyte as v) -> Some v | _ -> None + let (|SByte|_|) input = + match input with + | ValueObj (:? sbyte as v) -> Some v + | _ -> None [] - let (|Byte|_|) input = match input with ValueObj(:? byte as v) -> Some v | _ -> None + let (|Byte|_|) input = + match input with + | ValueObj (:? byte as v) -> Some v + | _ -> None [] - let (|Int16|_|) input = match input with ValueObj(:? int16 as v) -> Some v | _ -> None + let (|Int16|_|) input = + match input with + | ValueObj (:? int16 as v) -> Some v + | _ -> None [] - let (|UInt16|_|) input = match input with ValueObj(:? uint16 as v) -> Some v | _ -> None + let (|UInt16|_|) input = + match input with + | ValueObj (:? uint16 as v) -> Some v + | _ -> None [] - let (|Int32|_|) input = match input with ValueObj(:? int32 as v) -> Some v | _ -> None + let (|Int32|_|) input = + match input with + | ValueObj (:? int32 as v) -> Some v + | _ -> None [] - let (|UInt32|_|) input = match input with ValueObj(:? uint32 as v) -> Some v | _ -> None + let (|UInt32|_|) input = + match input with + | ValueObj (:? uint32 as v) -> Some v + | _ -> None [] - let (|Int64|_|) input = match input with ValueObj(:? int64 as v) -> Some v | _ -> None + let (|Int64|_|) input = + match input with + | ValueObj (:? int64 as v) -> Some v + | _ -> None [] - let (|UInt64|_|) input = match input with ValueObj(:? uint64 as v) -> Some v | _ -> None + let (|UInt64|_|) input = + match input with + | ValueObj (:? uint64 as v) -> Some v + | _ -> None [] - let (|Unit|_|) input = match input with Comb0(ValueOp(_, ty, None)) when ty = typeof -> Some() | _ -> None + let (|Unit|_|) input = + match input with + | Comb0 (ValueOp (_, ty, None)) when ty = typeof -> Some() + | _ -> None /// (fun (x, y) -> z) is represented as 'fun p -> let x = p#0 let y = p#1' etc. /// This reverses this encoding. @@ -2162,85 +2885,96 @@ module DerivedPatterns = /// Strip off the 'let' bindings for an TupledLambda let rec stripSuccessiveProjLets (p: Var) n expr = match expr with - | Let(v1, TupleGet(Var pA, m), rest) - when p = pA && m = n-> - let restvs, b = stripSuccessiveProjLets p (n+1) rest - v1 :: restvs, b + | Let (v1, TupleGet (Var pA, m), rest) when p = pA && m = n -> + let restvs, b = stripSuccessiveProjLets p (n + 1) rest + v1 :: restvs, b | _ -> ([], expr) + match lam.Tree with - | LambdaTerm(v, body) -> - match stripSuccessiveProjLets v 0 body with - | [], b -> Some([v], b) - | letvs, b -> Some(letvs, b) + | LambdaTerm (v, body) -> + match stripSuccessiveProjLets v 0 body with + | [], b -> Some([ v ], b) + | letvs, b -> Some(letvs, b) | _ -> None let (|TupledApplication|_|) e = match e with - | Application(f, x) -> + | Application (f, x) -> match x with | Unit -> Some(f, []) | NewTuple x -> Some(f, x) - | x -> Some(f, [x]) + | x -> Some(f, [ x ]) | _ -> None [] - let (|Lambdas|_|) (input: Expr) = qOneOrMoreRLinear (|TupledLambda|_|) input + let (|Lambdas|_|) (input: Expr) = + qOneOrMoreRLinear (|TupledLambda|_|) input [] - let (|Applications|_|) (input: Expr) = qOneOrMoreLLinear (|TupledApplication|_|) input + let (|Applications|_|) (input: Expr) = + qOneOrMoreLLinear (|TupledApplication|_|) input /// Reverse the compilation of And and Or [] let (|AndAlso|_|) input = match input with - | IfThenElse(x, y, Bool false) -> Some(x, y) + | IfThenElse (x, y, Bool false) -> Some(x, y) | _ -> None [] let (|OrElse|_|) input = match input with - | IfThenElse(x, Bool true, y) -> Some(x, y) + | IfThenElse (x, Bool true, y) -> Some(x, y) | _ -> None [] let (|SpecificCall|_|) templateParameter = // Note: precomputation match templateParameter with - | (Lambdas(_, Call(_, minfo1, _)) | Call(_, minfo1, _)) -> + | (Lambdas (_, Call (_, minfo1, _)) + | Call (_, minfo1, _)) -> let isg1 = minfo1.IsGenericMethod - let gmd = if isg1 then minfo1.GetGenericMethodDefinition() else null + + let gmd = + if isg1 then + minfo1.GetGenericMethodDefinition() + else + null // end-of-precomputation (fun tm -> - match tm with - | Call(obj, minfo2, args) + match tm with + | Call (obj, minfo2, args) when #if FX_NO_REFLECTION_METADATA_TOKENS - when ( // if metadata tokens are not available we'll rely only on equality of method references + ( // if metadata tokens are not available we'll rely only on equality of method references #else - when (minfo1.MetadataToken = minfo2.MetadataToken && + (minfo1.MetadataToken = minfo2.MetadataToken + && #endif - if isg1 then - minfo2.IsGenericMethod && gmd = minfo2.GetGenericMethodDefinition() - else - minfo1 = minfo2) -> - Some(obj, (minfo2.GetGenericArguments() |> Array.toList), args) - | _ -> None) - | _ -> - invalidArg "templateParameter" (SR.GetString(SR.QunrecognizedMethodCall)) + if isg1 then + minfo2.IsGenericMethod && gmd = minfo2.GetGenericMethodDefinition() + else + minfo1 = minfo2) + -> + Some(obj, (minfo2.GetGenericArguments() |> Array.toList), args) + | _ -> None) + | _ -> invalidArg "templateParameter" (SR.GetString(SR.QunrecognizedMethodCall)) let private new_decimal_info = - methodhandleof (fun (low, medium, high, isNegative, scale) -> LanguagePrimitives.IntrinsicFunctions.MakeDecimal low medium high isNegative scale) - |> System.Reflection.MethodInfo.GetMethodFromHandle - :?> MethodInfo + methodhandleof (fun (low, medium, high, isNegative, scale) -> + LanguagePrimitives.IntrinsicFunctions.MakeDecimal low medium high isNegative scale) + |> System.Reflection.MethodInfo.GetMethodFromHandle + :?> MethodInfo [] let (|Decimal|_|) input = match input with - | Call (None, mi, [Int32 low; Int32 medium; Int32 high; Bool isNegative; Byte scale]) - when mi.Name = new_decimal_info.Name - && mi.DeclaringType.FullName = new_decimal_info.DeclaringType.FullName -> - Some (LanguagePrimitives.IntrinsicFunctions.MakeDecimal low medium high isNegative scale) + | Call (None, mi, [ Int32 low; Int32 medium; Int32 high; Bool isNegative; Byte scale ]) when + mi.Name = new_decimal_info.Name + && mi.DeclaringType.FullName = new_decimal_info.DeclaringType.FullName + -> + Some(LanguagePrimitives.IntrinsicFunctions.MakeDecimal low medium high isNegative scale) | _ -> None [] @@ -2248,61 +2982,64 @@ module DerivedPatterns = Expr.TryGetReflectedDefinition methodBase [] - let (|PropertyGetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = - Expr.TryGetReflectedDefinition (propertyInfo.GetGetMethod true) + let (|PropertyGetterWithReflectedDefinition|_|) (propertyInfo: System.Reflection.PropertyInfo) = + Expr.TryGetReflectedDefinition(propertyInfo.GetGetMethod true) [] - let (|PropertySetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = - Expr.TryGetReflectedDefinition (propertyInfo.GetSetMethod true) + let (|PropertySetterWithReflectedDefinition|_|) (propertyInfo: System.Reflection.PropertyInfo) = + Expr.TryGetReflectedDefinition(propertyInfo.GetSetMethod true) [] module ExprShape = open Patterns - let RebuildShapeCombination(shape:obj, arguments) = + + let RebuildShapeCombination (shape: obj, arguments) = // preserve the attributes - let op, attrs = unbox(shape) + let op, attrs = unbox (shape) + let e = match op, arguments with - | AppOp, [f;x] -> mkApplication(f, x) - | IfThenElseOp, [g;t;e] -> mkIfThenElse(g, t, e) - | LetRecOp, [e1] -> mkLetRecRaw e1 + | AppOp, [ f; x ] -> mkApplication (f, x) + | IfThenElseOp, [ g; t; e ] -> mkIfThenElse (g, t, e) + | LetRecOp, [ e1 ] -> mkLetRecRaw e1 | LetRecCombOp, _ -> mkLetRecCombRaw arguments - | LetOp, [e1;e2] -> mkLetRawWithCheck(e1, e2) - | NewRecordOp ty, _ -> mkNewRecord(ty, arguments) - | NewUnionCaseOp unionCase, _ -> mkNewUnionCase(unionCase, arguments) - | UnionCaseTestOp unionCase, [arg] -> mkUnionCaseTest(unionCase, arg) - | NewTupleOp ty, _ -> mkNewTupleWithType(ty, arguments) - | TupleGetOp(ty, i), [arg] -> mkTupleGet(ty, i, arg) - | InstancePropGetOp pinfo, (obj :: args) -> mkInstancePropGet(obj, pinfo, args) - | StaticPropGetOp pinfo, _ -> mkStaticPropGet(pinfo, arguments) - | InstancePropSetOp pinfo, obj :: (FrontAndBack(args, v)) -> mkInstancePropSet(obj, pinfo, args, v) - | StaticPropSetOp pinfo, (FrontAndBack(args, v)) -> mkStaticPropSet(pinfo, args, v) - | InstanceFieldGetOp finfo, [obj] -> mkInstanceFieldGet(obj, finfo) - | StaticFieldGetOp finfo, [] -> mkStaticFieldGet(finfo ) - | InstanceFieldSetOp finfo, [obj;v] -> mkInstanceFieldSet(obj, finfo, v) - | StaticFieldSetOp finfo, [v] -> mkStaticFieldSet(finfo, v) - | NewObjectOp minfo, _ -> mkCtorCall(minfo, arguments) + | LetOp, [ e1; e2 ] -> mkLetRawWithCheck (e1, e2) + | NewRecordOp ty, _ -> mkNewRecord (ty, arguments) + | NewUnionCaseOp unionCase, _ -> mkNewUnionCase (unionCase, arguments) + | UnionCaseTestOp unionCase, [ arg ] -> mkUnionCaseTest (unionCase, arg) + | NewTupleOp ty, _ -> mkNewTupleWithType (ty, arguments) + | TupleGetOp (ty, i), [ arg ] -> mkTupleGet (ty, i, arg) + | InstancePropGetOp pinfo, (obj :: args) -> mkInstancePropGet (obj, pinfo, args) + | StaticPropGetOp pinfo, _ -> mkStaticPropGet (pinfo, arguments) + | InstancePropSetOp pinfo, obj :: (FrontAndBack (args, v)) -> mkInstancePropSet (obj, pinfo, args, v) + | StaticPropSetOp pinfo, (FrontAndBack (args, v)) -> mkStaticPropSet (pinfo, args, v) + | InstanceFieldGetOp finfo, [ obj ] -> mkInstanceFieldGet (obj, finfo) + | StaticFieldGetOp finfo, [] -> mkStaticFieldGet (finfo) + | InstanceFieldSetOp finfo, [ obj; v ] -> mkInstanceFieldSet (obj, finfo, v) + | StaticFieldSetOp finfo, [ v ] -> mkStaticFieldSet (finfo, v) + | NewObjectOp minfo, _ -> mkCtorCall (minfo, arguments) | DefaultValueOp ty, _ -> mkDefaultValue ty - | StaticMethodCallOp minfo, _ -> mkStaticMethodCall(minfo, arguments) - | InstanceMethodCallOp minfo, obj :: args -> mkInstanceMethodCall(obj, minfo, args) - | StaticMethodCallWOp (minfo, minfoW, n), _ -> mkStaticMethodCallW(minfo, minfoW, n, arguments) - | InstanceMethodCallWOp (minfo, minfoW, n), obj::args -> mkInstanceMethodCallW(obj, minfo, minfoW, n, args) - | CoerceOp ty, [arg] -> mkCoerce(ty, arg) - | NewArrayOp ty, _ -> mkNewArray(ty, arguments) - | NewDelegateOp ty, [arg] -> mkNewDelegate(ty, arg) - | SequentialOp, [e1;e2] -> mkSequential(e1, e2) - | TypeTestOp ty, [e1] -> mkTypeTest(e1, ty) - | AddressOfOp, [e1] -> mkAddressOf e1 - | VarSetOp, [E(VarTerm v); e] -> mkVarSet(v, e) - | AddressSetOp, [e1;e2] -> mkAddressSet(e1, e2) - | ForIntegerRangeLoopOp, [e1;e2;E(LambdaTerm(v, e3))] -> mkForLoop(v, e1, e2, e3) - | WhileLoopOp, [e1;e2] -> mkWhileLoop(e1, e2) - | TryFinallyOp, [e1;e2] -> mkTryFinally(e1, e2) - | TryWithOp, [e1;Lambda(v1, e2);Lambda(v2, e3)] -> mkTryWith(e1, v1, e2, v2, e3) - | QuoteOp flg, [e1] -> mkQuote(e1, flg) - | ValueOp(v, ty, None), [] -> mkValue(v, ty) - | ValueOp(v, ty, Some nm), [] -> mkValueWithName(v, ty, nm) - | WithValueOp(v, ty), [e] -> mkValueWithDefn(v, ty, e) + | StaticMethodCallOp minfo, _ -> mkStaticMethodCall (minfo, arguments) + | InstanceMethodCallOp minfo, obj :: args -> mkInstanceMethodCall (obj, minfo, args) + | StaticMethodCallWOp (minfo, minfoW, n), _ -> mkStaticMethodCallW (minfo, minfoW, n, arguments) + | InstanceMethodCallWOp (minfo, minfoW, n), obj :: args -> + mkInstanceMethodCallW (obj, minfo, minfoW, n, args) + | CoerceOp ty, [ arg ] -> mkCoerce (ty, arg) + | NewArrayOp ty, _ -> mkNewArray (ty, arguments) + | NewDelegateOp ty, [ arg ] -> mkNewDelegate (ty, arg) + | SequentialOp, [ e1; e2 ] -> mkSequential (e1, e2) + | TypeTestOp ty, [ e1 ] -> mkTypeTest (e1, ty) + | AddressOfOp, [ e1 ] -> mkAddressOf e1 + | VarSetOp, [ E (VarTerm v); e ] -> mkVarSet (v, e) + | AddressSetOp, [ e1; e2 ] -> mkAddressSet (e1, e2) + | ForIntegerRangeLoopOp, [ e1; e2; E (LambdaTerm (v, e3)) ] -> mkForLoop (v, e1, e2, e3) + | WhileLoopOp, [ e1; e2 ] -> mkWhileLoop (e1, e2) + | TryFinallyOp, [ e1; e2 ] -> mkTryFinally (e1, e2) + | TryWithOp, [ e1; Lambda (v1, e2); Lambda (v2, e3) ] -> mkTryWith (e1, v1, e2, v2, e3) + | QuoteOp flg, [ e1 ] -> mkQuote (e1, flg) + | ValueOp (v, ty, None), [] -> mkValue (v, ty) + | ValueOp (v, ty, Some nm), [] -> mkValueWithName (v, ty, nm) + | WithValueOp (v, ty), [ e ] -> mkValueWithDefn (v, ty, e) | _ -> invalidOp (SR.GetString(SR.QillFormedAppOrLet)) EA(e.Tree, attrs) @@ -2311,9 +3048,11 @@ module ExprShape = let rec (|ShapeVar|ShapeLambda|ShapeCombination|) input = let rec loop expr = let (E t) = expr + match t with | VarTerm v -> ShapeVar v - | LambdaTerm(v, b) -> ShapeLambda(v, b) - | CombTerm(op, args) -> ShapeCombination(box (op, expr.CustomAttributes), args) + | LambdaTerm (v, b) -> ShapeLambda(v, b) + | CombTerm (op, args) -> ShapeCombination(box (op, expr.CustomAttributes), args) | HoleTerm _ -> invalidArg "expr" (SR.GetString(SR.QunexpectedHole)) + loop (input :> Expr) diff --git a/src/FSharp.Core/reflect.fs b/src/FSharp.Core/reflect.fs index 63b8d6d4651..4bc089765fb 100644 --- a/src/FSharp.Core/reflect.fs +++ b/src/FSharp.Core/reflect.fs @@ -28,27 +28,35 @@ module internal ReflectionUtils = [] module internal Impl = - let getBindingFlags allowAccess = ReflectionUtils.toBindingFlags (defaultArg allowAccess false) + let getBindingFlags allowAccess = + ReflectionUtils.toBindingFlags (defaultArg allowAccess false) let inline checkNonNull argName (v: 'T) = match box v with | null -> nullArg argName | _ -> () - let isNamedType(typ: Type) = not (typ.IsArray || typ.IsByRef || typ.IsPointer) + let isNamedType (typ: Type) = + not (typ.IsArray || typ.IsByRef || typ.IsPointer) let equivHeadTypes (ty1: Type) (ty2: Type) = - isNamedType ty1 && - if ty1.IsGenericType then - ty2.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(ty2.GetGenericTypeDefinition()) - else - ty1.Equals ty2 + isNamedType ty1 + && if ty1.IsGenericType then + ty2.IsGenericType + && (ty1.GetGenericTypeDefinition()).Equals(ty2.GetGenericTypeDefinition()) + else + ty1.Equals ty2 let func = typedefof<(obj -> obj)> - let isOptionType typ = equivHeadTypes typ (typeof) - let isFunctionType typ = equivHeadTypes typ (typeof<(int -> int)>) - let isListType typ = equivHeadTypes typ (typeof) + let isOptionType typ = + equivHeadTypes typ (typeof) + + let isFunctionType typ = + equivHeadTypes typ (typeof<(int -> int)>) + + let isListType typ = + equivHeadTypes typ (typeof) //----------------------------------------------------------------- // GENERAL UTILITIES @@ -57,165 +65,180 @@ module internal Impl = let staticPropertyFlags = BindingFlags.GetProperty ||| BindingFlags.Static let staticFieldFlags = BindingFlags.GetField ||| BindingFlags.Static let staticMethodFlags = BindingFlags.Static - let getInstancePropertyInfo (typ: Type, propName, bindingFlags) = typ.GetProperty(propName, instancePropertyFlags ||| bindingFlags) - let getInstancePropertyInfos (typ, names, bindingFlags) = names |> Array.map (fun nm -> getInstancePropertyInfo (typ, nm, bindingFlags)) + + let getInstancePropertyInfo (typ: Type, propName, bindingFlags) = + typ.GetProperty(propName, instancePropertyFlags ||| bindingFlags) + + let getInstancePropertyInfos (typ, names, bindingFlags) = + names |> Array.map (fun nm -> getInstancePropertyInfo (typ, nm, bindingFlags)) + let getInstancePropertyReader (typ: Type, propName, bindingFlags) = - match getInstancePropertyInfo(typ, propName, bindingFlags) with + match getInstancePropertyInfo (typ, propName, bindingFlags) with | null -> None - | prop -> Some(fun (obj: obj) -> prop.GetValue (obj, instancePropertyFlags ||| bindingFlags, null, null, null)) + | prop -> Some(fun (obj: obj) -> prop.GetValue(obj, instancePropertyFlags ||| bindingFlags, null, null, null)) //----------------------------------------------------------------- // EXPRESSION TREE COMPILATION let compilePropGetterFunc (prop: PropertyInfo) = - let param = Expression.Parameter (typeof, "param") - + let param = Expression.Parameter(typeof, "param") + + let propExpr = + Expression.Property(Expression.Convert(param, prop.DeclaringType), prop) + let expr = - Expression.Lambda> ( - Expression.Convert ( - Expression.Property ( - Expression.Convert (param, prop.DeclaringType), - prop), - typeof), - param) - expr.Compile () + Expression.Lambda>(Expression.Convert(propExpr, typeof), param) + + expr.Compile() let compileRecordOrUnionCaseReaderFunc (typ, props: PropertyInfo[]) = - let param = Expression.Parameter (typeof, "param") + let param = Expression.Parameter(typeof, "param") let typedParam = Expression.Variable typ - + let expr = - Expression.Lambda> ( - Expression.Block ( + Expression.Lambda>( + Expression.Block( [ typedParam ], - Expression.Assign (typedParam, Expression.Convert (param, typ)), - Expression.NewArrayInit (typeof, [ - for prop in props -> - Expression.Convert (Expression.Property (typedParam, prop), typeof) :> Expression - ]) + Expression.Assign(typedParam, Expression.Convert(param, typ)), + Expression.NewArrayInit( + typeof, + [ + for prop in props -> + Expression.Convert(Expression.Property(typedParam, prop), typeof) :> Expression + ] + ) ), - param) - expr.Compile () + param + ) + + expr.Compile() let compileRecordConstructorFunc (ctorInfo: ConstructorInfo) = - let ctorParams = ctorInfo.GetParameters () - let paramArray = Expression.Parameter (typeof, "paramArray") + let ctorParams = ctorInfo.GetParameters() + let paramArray = Expression.Parameter(typeof, "paramArray") let expr = - Expression.Lambda> ( - Expression.Convert ( - Expression.New ( + Expression.Lambda>( + Expression.Convert( + Expression.New( ctorInfo, [ for paramIndex in 0 .. ctorParams.Length - 1 do let p = ctorParams.[paramIndex] - Expression.Convert ( - Expression.ArrayAccess (paramArray, Expression.Constant paramIndex), - p.ParameterType - ) :> Expression + let accessExpr = Expression.ArrayAccess(paramArray, Expression.Constant paramIndex) + Expression.Convert(accessExpr, p.ParameterType) :> Expression ] ), - typeof), + typeof + ), paramArray ) - expr.Compile () + + expr.Compile() let compileUnionCaseConstructorFunc (methodInfo: MethodInfo) = - let methodParams = methodInfo.GetParameters () - let paramArray = Expression.Parameter (typeof, "param") - + let methodParams = methodInfo.GetParameters() + let paramArray = Expression.Parameter(typeof, "param") + let expr = - Expression.Lambda> ( - Expression.Convert ( - Expression.Call ( + Expression.Lambda>( + Expression.Convert( + Expression.Call( methodInfo, [ for paramIndex in 0 .. methodParams.Length - 1 do let p = methodParams.[paramIndex] - Expression.Convert ( - Expression.ArrayAccess (paramArray, Expression.Constant paramIndex), - p.ParameterType - ) :> Expression + let accessExpr = Expression.ArrayAccess(paramArray, Expression.Constant paramIndex) + Expression.Convert(accessExpr, p.ParameterType) :> Expression ] ), - typeof), + typeof + ), paramArray ) - expr.Compile () + + expr.Compile() let compileUnionTagReaderFunc (info: Choice) = - let param = Expression.Parameter (typeof, "param") + let param = Expression.Parameter(typeof, "param") + let tag = match info with - | Choice1Of2 info -> Expression.Call (info, Expression.Convert (param, info.DeclaringType)) :> Expression - | Choice2Of2 info -> Expression.Property (Expression.Convert (param, info.DeclaringType), info) :> _ - - let expr = - Expression.Lambda> ( - tag, - param) - expr.Compile () + | Choice1Of2 info -> Expression.Call(info, Expression.Convert(param, info.DeclaringType)) :> Expression + | Choice2Of2 info -> Expression.Property(Expression.Convert(param, info.DeclaringType), info) :> _ + + let expr = Expression.Lambda>(tag, param) + expr.Compile() let compileTupleConstructor tupleEncField getTupleConstructorMethod typ = let rec constituentTuple (typ: Type) elements startIndex = - Expression.New ( + Expression.New( getTupleConstructorMethod typ, [ - let genericArgs = typ.GetGenericArguments () + let genericArgs = typ.GetGenericArguments() for paramIndex in 0 .. genericArgs.Length - 1 do let genericArg = genericArgs.[paramIndex] - + if paramIndex = tupleEncField then constituentTuple genericArg elements (startIndex + paramIndex) :> Expression else - Expression.Convert (Expression.ArrayAccess (elements, Expression.Constant (startIndex + paramIndex)), genericArg) - ]) + Expression.Convert( + Expression.ArrayAccess(elements, Expression.Constant(startIndex + paramIndex)), + genericArg + ) + ] + ) - let elements = Expression.Parameter (typeof, "elements") + let elements = Expression.Parameter(typeof, "elements") let expr = - Expression.Lambda> ( - Expression.Convert ( - constituentTuple typ elements 0, - typeof - ), + Expression.Lambda>( + Expression.Convert(constituentTuple typ elements 0, typeof), elements ) - expr.Compile () + expr.Compile() let compileTupleReader tupleEncField getTupleElementAccessors typ = - let rec writeTupleIntoArray (typ: Type) (tuple: Expression) outputArray startIndex = seq { - let elements = - match getTupleElementAccessors typ with - // typ is a struct tuple and its elements are accessed via fields - | Choice1Of2 (fi: FieldInfo[]) -> fi |> Array.map (fun fi -> Expression.Field (tuple, fi), fi.FieldType) - // typ is a class tuple and its elements are accessed via properties - | Choice2Of2 (pi: PropertyInfo[]) -> pi |> Array.map (fun pi -> Expression.Property (tuple, pi), pi.PropertyType) - - for index, (element, elementType) in elements |> Array.indexed do - if index = tupleEncField then - let innerTupleParam = Expression.Parameter (elementType, "innerTuple") - Expression.Block ( - [ innerTupleParam ], - [ - yield Expression.Assign (innerTupleParam, element) :> Expression - yield! writeTupleIntoArray elementType innerTupleParam outputArray (startIndex + index) - ] - ) :> Expression - else - Expression.Assign ( - Expression.ArrayAccess (outputArray, Expression.Constant (index + startIndex)), - Expression.Convert (element, typeof) - ) :> Expression } + let rec writeTupleIntoArray (typ: Type) (tuple: Expression) outputArray startIndex = + seq { + let elements = + match getTupleElementAccessors typ with + // typ is a struct tuple and its elements are accessed via fields + | Choice1Of2 (fi: FieldInfo[]) -> + fi |> Array.map (fun fi -> Expression.Field(tuple, fi), fi.FieldType) + // typ is a class tuple and its elements are accessed via properties + | Choice2Of2 (pi: PropertyInfo[]) -> + pi |> Array.map (fun pi -> Expression.Property(tuple, pi), pi.PropertyType) + + for index, (element, elementType) in elements |> Array.indexed do + if index = tupleEncField then + let innerTupleParam = Expression.Parameter(elementType, "innerTuple") + + Expression.Block( + [ innerTupleParam ], + [ + yield Expression.Assign(innerTupleParam, element) :> Expression + yield! writeTupleIntoArray elementType innerTupleParam outputArray (startIndex + index) + ] + ) + :> Expression + else + Expression.Assign( + Expression.ArrayAccess(outputArray, Expression.Constant(index + startIndex)), + Expression.Convert(element, typeof) + ) + :> Expression + } + + let param = Expression.Parameter(typeof, "outerTuple") + let outputArray = Expression.Variable(typeof, "output") - let param = Expression.Parameter (typeof, "outerTuple") - let outputArray = Expression.Variable (typeof, "output") let rec outputLength tupleEncField (typ: Type) = - let genericArgs = typ.GetGenericArguments () + let genericArgs = typ.GetGenericArguments() if genericArgs.Length > tupleEncField then tupleEncField + outputLength tupleEncField genericArgs.[genericArgs.Length - 1] @@ -223,35 +246,39 @@ module internal Impl = genericArgs.Length let expr = - Expression.Lambda> ( - Expression.Block ( + Expression.Lambda>( + Expression.Block( [ outputArray ], [ - yield Expression.Assign ( - outputArray, - Expression.NewArrayBounds (typeof, Expression.Constant (outputLength tupleEncField typ)) - ) :> Expression - yield! writeTupleIntoArray typ (Expression.Convert (param, typ)) outputArray 0 - yield outputArray :> Expression + let arrayBounds = + Expression.NewArrayBounds(typeof, Expression.Constant(outputLength tupleEncField typ)) + + Expression.Assign(outputArray, arrayBounds) :> Expression + yield! writeTupleIntoArray typ (Expression.Convert(param, typ)) outputArray 0 + outputArray :> Expression ] ), - param) + param + ) - expr.Compile () + expr.Compile() //----------------------------------------------------------------- // ATTRIBUTE DECOMPILATION let tryFindCompilationMappingAttribute (attrs: obj[]) = - match attrs with - | null | [| |] -> None - | [| res |] -> let a = (res :?> CompilationMappingAttribute) in Some (a.SourceConstructFlags, a.SequenceNumber, a.VariantNumber) - | _ -> invalidOp (SR.GetString (SR.multipleCompilationMappings)) + match attrs with + | null + | [||] -> None + | [| res |] -> + let a = (res :?> CompilationMappingAttribute) + Some(a.SourceConstructFlags, a.SequenceNumber, a.VariantNumber) + | _ -> invalidOp (SR.GetString(SR.multipleCompilationMappings)) let findCompilationMappingAttribute (attrs: obj[]) = - match tryFindCompilationMappingAttribute attrs with - | None -> failwith "no compilation mapping attribute" - | Some a -> a + match tryFindCompilationMappingAttribute attrs with + | None -> failwith "no compilation mapping attribute" + | Some a -> a let cmaName = typeof.FullName let assemblyName = typeof.Assembly.GetName().Name @@ -262,58 +289,85 @@ module internal Impl = | null -> None | _ -> let mutable res = None + for a in attrs do if a.Constructor.DeclaringType.FullName = cmaName then let args = a.ConstructorArguments + let flags = - match args.Count with - | 1 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), 0, 0) - | 2 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), (let x = args.[1] in x.Value :?> int), 0) - | 3 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), (let x = args.[1] in x.Value :?> int), (let x = args.[2] in x.Value :?> int)) - | _ -> (enum 0, 0, 0) + match args.Count with + | 1 -> + let arg0 = args.[0] + let v0 = arg0.Value :?> SourceConstructFlags + (v0, 0, 0) + | 2 -> + let arg0 = args.[0] + let v0 = arg0.Value :?> SourceConstructFlags + let arg1 = args.[1] + let v1 = arg1.Value :?> int + (v0, v1, 0) + | 3 -> + let arg0 = args.[0] + let v0 = arg0.Value :?> SourceConstructFlags + let arg1 = args.[1] + let v1 = arg1.Value :?> int + let arg2 = args.[2] + let v2 = arg2.Value :?> int + (v0, v1, v2) + | _ -> (enum 0, 0, 0) + res <- Some flags + res let findCompilationMappingAttributeFromData attrs = - match tryFindCompilationMappingAttributeFromData attrs with - | None -> failwith "no compilation mapping attribute" - | Some a -> a + match tryFindCompilationMappingAttributeFromData attrs with + | None -> failwith "no compilation mapping attribute" + | Some a -> a - let tryFindCompilationMappingAttributeFromType (typ: Type) = + let tryFindCompilationMappingAttributeFromType (typ: Type) = let assem = typ.Assembly + if (not (isNull assem)) && assem.ReflectionOnly then - tryFindCompilationMappingAttributeFromData ( typ.GetCustomAttributesData()) + tryFindCompilationMappingAttributeFromData (typ.GetCustomAttributesData()) else - tryFindCompilationMappingAttribute ( typ.GetCustomAttributes (typeof, false)) + tryFindCompilationMappingAttribute (typ.GetCustomAttributes(typeof, false)) let tryFindCompilationMappingAttributeFromMemberInfo (info: MemberInfo) = let assem = info.DeclaringType.Assembly + if (not (isNull assem)) && assem.ReflectionOnly then - tryFindCompilationMappingAttributeFromData (info.GetCustomAttributesData()) + tryFindCompilationMappingAttributeFromData (info.GetCustomAttributesData()) else - tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof, false)) + tryFindCompilationMappingAttribute (info.GetCustomAttributes(typeof, false)) - let findCompilationMappingAttributeFromMemberInfo (info: MemberInfo) = + let findCompilationMappingAttributeFromMemberInfo (info: MemberInfo) = let assem = info.DeclaringType.Assembly + if (not (isNull assem)) && assem.ReflectionOnly then findCompilationMappingAttributeFromData (info.GetCustomAttributesData()) else - findCompilationMappingAttribute (info.GetCustomAttributes (typeof, false)) + findCompilationMappingAttribute (info.GetCustomAttributes(typeof, false)) + + let sequenceNumberOfMember (x: MemberInfo) = + let (_, n, _) = findCompilationMappingAttributeFromMemberInfo x in n - let sequenceNumberOfMember (x: MemberInfo) = let (_, n, _) = findCompilationMappingAttributeFromMemberInfo x in n - let variantNumberOfMember (x: MemberInfo) = let (_, _, vn) = findCompilationMappingAttributeFromMemberInfo x in vn + let variantNumberOfMember (x: MemberInfo) = + let (_, _, vn) = findCompilationMappingAttributeFromMemberInfo x in vn - let sortFreshArray f arr = Array.sortInPlaceWith f arr; arr + let sortFreshArray f arr = + Array.sortInPlaceWith f arr + arr - let isFieldProperty (prop : PropertyInfo) = + let isFieldProperty (prop: PropertyInfo) = match tryFindCompilationMappingAttributeFromMemberInfo prop with | None -> false | Some (flags, _n, _vn) -> (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Field let tryFindSourceConstructFlagsOfType (typ: Type) = - match tryFindCompilationMappingAttributeFromType typ with - | None -> None - | Some (flags, _n, _vn) -> Some flags + match tryFindCompilationMappingAttributeFromType typ with + | None -> None + | Some (flags, _n, _vn) -> Some flags //----------------------------------------------------------------- // UNION DECOMPILATION @@ -321,11 +375,14 @@ module internal Impl = // Get the type where the type definitions are stored let getUnionCasesTyp (typ: Type, _bindingFlags) = #if CASES_IN_NESTED_CLASS - let casesTyp = typ.GetNestedType("Cases", bindingFlags) - if casesTyp.IsGenericTypeDefinition then casesTyp.MakeGenericType(typ.GetGenericArguments()) - else casesTyp + let casesTyp = typ.GetNestedType("Cases", bindingFlags) + + if casesTyp.IsGenericTypeDefinition then + casesTyp.MakeGenericType(typ.GetGenericArguments()) + else + casesTyp #else - typ + typ #endif let getUnionTypeTagNameMap (typ: Type, bindingFlags) = @@ -343,11 +400,16 @@ module internal Impl = // chop "get_" or "New" off the front let nm = if not (isListType typ) && not (isOptionType typ) && nm.Length > 3 then - if nm.StartsWith ("get_", StringComparison.Ordinal) then nm.[4..] - elif nm.StartsWith ("New", StringComparison.Ordinal) then nm.[3..] - else nm - else nm - Some (n, nm) + if nm.StartsWith("get_", StringComparison.Ordinal) then + nm.[4..] + elif nm.StartsWith("New", StringComparison.Ordinal) then + nm.[3..] + else + nm + else + nm + + Some(n, nm) else None) | _ -> @@ -357,8 +419,11 @@ module internal Impl = |> Array.map (fun tagfield -> (tagfield.GetValue null :?> int), tagfield.Name) let getUnionCaseTyp (typ: Type, tag: int, bindingFlags) = - let tagFields = getUnionTypeTagNameMap(typ, bindingFlags) - let tagField = tagFields |> Array.pick (fun (i, f) -> if i = tag then Some f else None) + let tagFields = getUnionTypeTagNameMap (typ, bindingFlags) + + let tagField = + tagFields |> Array.pick (fun (i, f) -> if i = tag then Some f else None) + if tagFields.Length = 1 then typ else @@ -367,75 +432,107 @@ module internal Impl = let isTwoCasedDU = if tagFields.Length = 2 then match typ.GetCustomAttributes(typeof, false) with - | [|:? CompilationRepresentationAttribute as attr|] -> + | [| :? CompilationRepresentationAttribute as attr |] -> (attr.Flags &&& CompilationRepresentationFlags.UseNullAsTrueValue) = CompilationRepresentationFlags.UseNullAsTrueValue | _ -> false else false + if isTwoCasedDU then typ else - let casesTyp = getUnionCasesTyp (typ, bindingFlags) - let caseTyp = casesTyp.GetNestedType(tagField, bindingFlags) // if this is null then the union is nullary - match caseTyp with - | null -> null - | _ when caseTyp.IsGenericTypeDefinition -> caseTyp.MakeGenericType(casesTyp.GetGenericArguments()) - | _ -> caseTyp + let casesTyp = getUnionCasesTyp (typ, bindingFlags) + let caseTyp = casesTyp.GetNestedType(tagField, bindingFlags) // if this is null then the union is nullary + + match caseTyp with + | null -> null + | _ when caseTyp.IsGenericTypeDefinition -> caseTyp.MakeGenericType(casesTyp.GetGenericArguments()) + | _ -> caseTyp let getUnionTagConverter (typ: Type, bindingFlags) = - if isOptionType typ then (fun tag -> match tag with 0 -> "None" | 1 -> "Some" | _ -> invalidArg "tag" (SR.GetString (SR.outOfRange))) - elif isListType typ then (fun tag -> match tag with 0 -> "Empty" | 1 -> "Cons" | _ -> invalidArg "tag" (SR.GetString (SR.outOfRange))) + if isOptionType typ then + (fun tag -> + match tag with + | 0 -> "None" + | 1 -> "Some" + | _ -> invalidArg "tag" (SR.GetString(SR.outOfRange))) + elif isListType typ then + (fun tag -> + match tag with + | 0 -> "Empty" + | 1 -> "Cons" + | _ -> invalidArg "tag" (SR.GetString(SR.outOfRange))) else - let tagfieldmap = getUnionTypeTagNameMap (typ, bindingFlags) |> Map.ofSeq - (fun tag -> tagfieldmap.[tag]) + let tagfieldmap = getUnionTypeTagNameMap (typ, bindingFlags) |> Map.ofSeq + (fun tag -> tagfieldmap.[tag]) let isUnionType (typ: Type, bindingFlags: BindingFlags) = - isOptionType typ || - isListType typ || - match tryFindSourceConstructFlagsOfType typ with - | None -> false - | Some flags -> - (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.SumType && - // We see private representations only if BindingFlags.NonPublic is set - (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum 0 then - (bindingFlags &&& BindingFlags.NonPublic) <> enum 0 - else - true) + isOptionType typ + || isListType typ + || match tryFindSourceConstructFlagsOfType typ with + | None -> false + | Some flags -> + (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.SumType + && + // We see private representations only if BindingFlags.NonPublic is set + (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum 0 then + (bindingFlags &&& BindingFlags.NonPublic) <> enum 0 + else + true) // Check the base type - if it is also an F# type then // for the moment we know it is a Discriminated Union let isConstructorRepr (typ, bindingFlags) = - let rec get typ = isUnionType (typ, bindingFlags) || match typ.BaseType with null -> false | b -> get b + let rec get typ = + isUnionType (typ, bindingFlags) + || match typ.BaseType with + | null -> false + | b -> get b + get typ let unionTypeOfUnionCaseType (typ, bindingFlags) = - let rec get typ = if isUnionType (typ, bindingFlags) then typ else match typ.BaseType with null -> typ | b -> get b + let rec get typ = + if isUnionType (typ, bindingFlags) then + typ + else + match typ.BaseType with + | null -> typ + | b -> get b + get typ let fieldsPropsOfUnionCase (typ, tag, bindingFlags) = if isOptionType typ then match tag with - | 0 (* None *) -> getInstancePropertyInfos (typ, [| |], bindingFlags) - | 1 (* Some *) -> getInstancePropertyInfos (typ, [| "Value" |], bindingFlags) + | 0 (* None *) -> getInstancePropertyInfos (typ, [||], bindingFlags) + | 1 (* Some *) -> getInstancePropertyInfos (typ, [| "Value" |], bindingFlags) | _ -> failwith "fieldsPropsOfUnionCase" elif isListType typ then match tag with - | 0 (* Nil *) -> getInstancePropertyInfos (typ, [| |], bindingFlags) - | 1 (* Cons *) -> getInstancePropertyInfos (typ, [| "Head"; "Tail" |], bindingFlags) + | 0 (* Nil *) -> getInstancePropertyInfos (typ, [||], bindingFlags) + | 1 (* Cons *) -> getInstancePropertyInfos (typ, [| "Head"; "Tail" |], bindingFlags) | _ -> failwith "fieldsPropsOfUnionCase" else // Lookup the type holding the fields for the union case let caseTyp = getUnionCaseTyp (typ, tag, bindingFlags) - let caseTyp = match caseTyp with null -> typ | _ -> caseTyp + + let caseTyp = + match caseTyp with + | null -> typ + | _ -> caseTyp + caseTyp.GetProperties(instancePropertyFlags ||| bindingFlags) |> Array.filter isFieldProperty |> Array.filter (fun prop -> variantNumberOfMember prop = tag) |> sortFreshArray (fun p1 p2 -> compare (sequenceNumberOfMember p1) (sequenceNumberOfMember p2)) - let getUnionCaseRecordReader (typ: Type, tag: int, bindingFlags) = let props = fieldsPropsOfUnionCase (typ, tag, bindingFlags) - (fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue (obj, bindingFlags, null, null, null))) + + (fun (obj: obj) -> + props + |> Array.map (fun prop -> prop.GetValue(obj, bindingFlags, null, null, null))) let getUnionCaseRecordReaderCompiled (typ: Type, tag: int, bindingFlags) = let props = fieldsPropsOfUnionCase (typ, tag, bindingFlags) @@ -445,29 +542,41 @@ module internal Impl = let getUnionTagReader (typ: Type, bindingFlags) : (obj -> int) = if isOptionType typ then - (fun (obj: obj) -> match obj with null -> 0 | _ -> 1) + (fun (obj: obj) -> + match obj with + | null -> 0 + | _ -> 1) else let tagMap = getUnionTypeTagNameMap (typ, bindingFlags) + if tagMap.Length <= 1 then (fun (_obj: obj) -> 0) else match getInstancePropertyReader (typ, "Tag", bindingFlags) with | Some reader -> (fun (obj: obj) -> reader obj :?> int) | None -> - let m2b = typ.GetMethod("GetTag", BindingFlags.Static ||| bindingFlags, null, [| typ |], null) - (fun (obj: obj) -> m2b.Invoke(null, [|obj|]) :?> int) + let m2b = + typ.GetMethod("GetTag", BindingFlags.Static ||| bindingFlags, null, [| typ |], null) + + (fun (obj: obj) -> m2b.Invoke(null, [| obj |]) :?> int) let getUnionTagReaderCompiled (typ: Type, bindingFlags) : (obj -> int) = if isOptionType typ then - (fun (obj: obj) -> match obj with null -> 0 | _ -> 1) + (fun (obj: obj) -> + match obj with + | null -> 0 + | _ -> 1) else let tagMap = getUnionTypeTagNameMap (typ, bindingFlags) + if tagMap.Length <= 1 then (fun (_obj: obj) -> 0) else match getInstancePropertyInfo (typ, "Tag", bindingFlags) with | null -> - let m2b = typ.GetMethod("GetTag", BindingFlags.Static ||| bindingFlags, null, [| typ |], null) + let m2b = + typ.GetMethod("GetTag", BindingFlags.Static ||| bindingFlags, null, [| typ |], null) + compileUnionTagReaderFunc(Choice1Of2 m2b).Invoke | info -> compileUnionTagReaderFunc(Choice2Of2 info).Invoke @@ -481,17 +590,24 @@ module internal Impl = let getUnionCaseConstructorMethod (typ: Type, tag: int, bindingFlags) = let constrname = getUnionTagConverter (typ, bindingFlags) tag + let methname = - if isUnionCaseNullary (typ, tag, bindingFlags) then "get_" + constrname - elif isListType typ || isOptionType typ then constrname - else "New" + constrname + if isUnionCaseNullary (typ, tag, bindingFlags) then + "get_" + constrname + elif isListType typ || isOptionType typ then + constrname + else + "New" + constrname - match typ.GetMethod(methname, BindingFlags.Static ||| bindingFlags) with - | null -> invalidOp (String.Format (SR.GetString (SR.constructorForUnionCaseNotFound), methname)) + match typ.GetMethod(methname, BindingFlags.Static ||| bindingFlags) with + | null -> + let msg = String.Format(SR.GetString(SR.constructorForUnionCaseNotFound), methname) + invalidOp msg | meth -> meth let getUnionCaseConstructor (typ: Type, tag: int, bindingFlags) = let meth = getUnionCaseConstructorMethod (typ, tag, bindingFlags) + (fun args -> meth.Invoke(null, BindingFlags.Static ||| BindingFlags.InvokeMethod ||| bindingFlags, null, args, null)) @@ -501,51 +617,58 @@ module internal Impl = let checkUnionType (unionType, bindingFlags) = checkNonNull "unionType" unionType + if not (isUnionType (unionType, bindingFlags)) then if isUnionType (unionType, bindingFlags ||| BindingFlags.NonPublic) then - invalidArg "unionType" (String.Format (SR.GetString (SR.privateUnionType), unionType.FullName)) + let msg = String.Format(SR.GetString(SR.privateUnionType), unionType.FullName) + invalidArg "unionType" msg else - invalidArg "unionType" (String.Format (SR.GetString (SR.notAUnionType), unionType.FullName)) + let msg = String.Format(SR.GetString(SR.notAUnionType), unionType.FullName) + invalidArg "unionType" msg //----------------------------------------------------------------- // TUPLE DECOMPILATION let tupleNames = - [| "System.Tuple`1" - "System.Tuple`2" - "System.Tuple`3" - "System.Tuple`4" - "System.Tuple`5" - "System.Tuple`6" - "System.Tuple`7" - "System.Tuple`8" - "System.Tuple" - "System.ValueTuple`1" - "System.ValueTuple`2" - "System.ValueTuple`3" - "System.ValueTuple`4" - "System.ValueTuple`5" - "System.ValueTuple`6" - "System.ValueTuple`7" - "System.ValueTuple`8" - "System.ValueTuple" |] - - let simpleTupleNames = - [| "Tuple`1" - "Tuple`2" - "Tuple`3" - "Tuple`4" - "Tuple`5" - "Tuple`6" - "Tuple`7" - "Tuple`8" - "ValueTuple`1" - "ValueTuple`2" - "ValueTuple`3" - "ValueTuple`4" - "ValueTuple`5" - "ValueTuple`6" - "ValueTuple`7" - "ValueTuple`8" |] + [| + "System.Tuple`1" + "System.Tuple`2" + "System.Tuple`3" + "System.Tuple`4" + "System.Tuple`5" + "System.Tuple`6" + "System.Tuple`7" + "System.Tuple`8" + "System.Tuple" + "System.ValueTuple`1" + "System.ValueTuple`2" + "System.ValueTuple`3" + "System.ValueTuple`4" + "System.ValueTuple`5" + "System.ValueTuple`6" + "System.ValueTuple`7" + "System.ValueTuple`8" + "System.ValueTuple" + |] + + let simpleTupleNames = + [| + "Tuple`1" + "Tuple`2" + "Tuple`3" + "Tuple`4" + "Tuple`5" + "Tuple`6" + "Tuple`7" + "Tuple`8" + "ValueTuple`1" + "ValueTuple`2" + "ValueTuple`3" + "ValueTuple`4" + "ValueTuple`5" + "ValueTuple`6" + "ValueTuple`7" + "ValueTuple`8" + |] let isTupleType (typ: Type) = // We need to be careful that we only rely typ.IsGenericType, typ.Namespace and typ.Name here. @@ -554,15 +677,15 @@ module internal Impl = // System.Type that don't have functionality such as .IsEnum and .FullName fully implemented. // This happens particularly over TypeBuilderInstantiation types in the ProvideTypes implementation of System.Type // used in F# type providers. - typ.IsGenericType && - typ.Namespace = "System" && - simpleTupleNames |> Seq.exists typ.Name.StartsWith + typ.IsGenericType + && typ.Namespace = "System" + && simpleTupleNames |> Seq.exists typ.Name.StartsWith let maxTuple = 8 // Which field holds the nested tuple? let tupleEncField = maxTuple - 1 - let dictionaryLock = obj() + let dictionaryLock = obj () let refTupleTypes = Dictionary() let valueTupleTypes = Dictionary() @@ -583,18 +706,25 @@ module internal Impl = | 6 -> asm.GetType(tupleFullName 6) | 7 -> asm.GetType(tupleFullName 7) | 8 -> asm.GetType(tupleFullName 8) - | _ -> invalidArg "tys" (SR.GetString (SR.invalidTupleTypes)) + | _ -> invalidArg "tys" (SR.GetString(SR.invalidTupleTypes)) + + let tables = + if isStruct then + valueTupleTypes + else + refTupleTypes - let tables = if isStruct then valueTupleTypes else refTupleTypes match lock dictionaryLock (fun () -> tables.TryGetValue asm) with | false, _ -> // the Dictionary<>s here could be ConcurrentDictionary<>'s, but then // that would lock while initializing the Type array (maybe not an issue) let mutable a = Array.init 8 (fun i -> makeIt (i + 1)) + lock dictionaryLock (fun () -> match tables.TryGetValue asm with | true, t -> a <- t | false, _ -> tables.Add(asm, a)) + a | true, t -> t @@ -607,18 +737,21 @@ module internal Impl = | 6 -> table.[5].MakeGenericType tys | 7 -> table.[6].MakeGenericType tys | n when n >= maxTuple -> - let tysA = tys.[0..tupleEncField-1] - let tysB = tys.[maxTuple-1..] + let tysA = tys.[0 .. tupleEncField - 1] + let tysB = tys.[maxTuple - 1 ..] let tyB = mkTupleType isStruct asm tysB table.[7].MakeGenericType(Array.append tysA [| tyB |]) - | _ -> invalidArg "tys" (SR.GetString (SR.invalidTupleTypes)) + | _ -> invalidArg "tys" (SR.GetString(SR.invalidTupleTypes)) let rec getTupleTypeInfo (typ: Type) = if not (isTupleType typ) then - invalidArg "typ" (String.Format (SR.GetString (SR.notATupleType), typ.FullName)) + let msg = String.Format(SR.GetString(SR.notATupleType), typ.FullName) + invalidArg "typ" msg + let tyargs = typ.GetGenericArguments() + if tyargs.Length = maxTuple then - let tysA = tyargs.[0..tupleEncField-1] + let tysA = tyargs.[0 .. tupleEncField - 1] let tyB = tyargs.[tupleEncField] Array.append tysA (getTupleTypeInfo tyB) else @@ -632,17 +765,28 @@ module internal Impl = // Item1, Item2, ..., Item, Rest // The PropertyInfo may not come back in order, so ensure ordering here. #if !NETSTANDARD - assert(maxTuple < 10) // Alphasort will only works for upto 9 items: Item1, Item10, Item2, Item3, ..., Item9, Rest + assert (maxTuple < 10) // Alphasort will only works for upto 9 items: Item1, Item10, Item2, Item3, ..., Item9, Rest #endif let props = props |> Array.sortBy (fun p -> p.Name) // they are not always in alphabetic order #if !NETSTANDARD - assert(props.Length <= maxTuple) - assert(let haveNames = props |> Array.map (fun p -> p.Name) - let expectNames = Array.init props.Length (fun i -> let j = i+1 // index j = 1, 2, .., props.Length <= maxTuple - if j Array.map (fun p -> p.Name) + + let expectNames = + Array.init props.Length (fun i -> + let j = i + 1 // index j = 1, 2, .., props.Length <= maxTuple + + if j < maxTuple then + "Item" + string j + elif j = maxTuple then + "Rest" + else + (assert false + "")) // dead code under prior assert, props.Length <= maxTuple + + haveNames = expectNames) #endif props @@ -654,43 +798,75 @@ module internal Impl = // Item1, Item2, ..., Item, Rest // The PropertyInfo may not come back in order, so ensure ordering here. #if !NETSTANDARD - assert(maxTuple < 10) // Alphasort will only works for upto 9 items: Item1, Item10, Item2, Item3, ..., Item9, Rest + assert (maxTuple < 10) // Alphasort will only works for upto 9 items: Item1, Item10, Item2, Item3, ..., Item9, Rest #endif let fields = fields |> Array.sortBy (fun fi -> fi.Name) // they are not always in alphabetic order #if !NETSTANDARD - assert(fields.Length <= maxTuple) - assert(let haveNames = fields |> Array.map (fun fi -> fi.Name) - let expectNames = Array.init fields.Length (fun i -> let j = i+1 // index j = 1, 2, .., fields.Length <= maxTuple - if j Array.map (fun fi -> fi.Name) + + let expectNames = + Array.init fields.Length (fun i -> + let j = i + 1 // index j = 1, 2, .., fields.Length <= maxTuple + + if j < maxTuple then + "Item" + string j + elif j = maxTuple then + "Rest" + else + (assert false + "")) // dead code under prior assert, props.Length <= maxTuple + + haveNames = expectNames) #endif fields let getTupleConstructorMethod (typ: Type) = let ctor = if typ.IsValueType then - let fields = typ.GetFields (instanceFieldFlags ||| BindingFlags.Public) |> orderTupleFields - typ.GetConstructor(BindingFlags.Public ||| BindingFlags.Instance, null, fields |> Array.map (fun fi -> fi.FieldType), null) + let fields = + typ.GetFields(instanceFieldFlags ||| BindingFlags.Public) |> orderTupleFields + + typ.GetConstructor( + BindingFlags.Public ||| BindingFlags.Instance, + null, + fields |> Array.map (fun fi -> fi.FieldType), + null + ) else let props = typ.GetProperties() |> orderTupleProperties - typ.GetConstructor(BindingFlags.Public ||| BindingFlags.Instance, null, props |> Array.map (fun p -> p.PropertyType), null) + + typ.GetConstructor( + BindingFlags.Public ||| BindingFlags.Instance, + null, + props |> Array.map (fun p -> p.PropertyType), + null + ) + match ctor with - | null -> raise (ArgumentException (String.Format (SR.GetString (SR.invalidTupleTypeConstructorNotDefined), typ.FullName))) + | null -> + let msg = String.Format(SR.GetString(SR.invalidTupleTypeConstructorNotDefined)) + raise (ArgumentException(msg, typ.FullName)) | _ -> () + ctor - let getTupleCtor(typ: Type) = - let ctor = getTupleConstructorMethod typ - (fun (args: obj[]) -> - ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public, null, args, null)) + let getTupleCtor (typ: Type) = + let ctor = getTupleConstructorMethod typ + + (fun (args: obj[]) -> + ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public, null, args, null)) let getTupleElementAccessors (typ: Type) = if typ.IsValueType then - Choice1Of2 (typ.GetFields (instanceFieldFlags ||| BindingFlags.Public) |> orderTupleFields) + Choice1Of2(typ.GetFields(instanceFieldFlags ||| BindingFlags.Public) |> orderTupleFields) else - Choice2Of2 (typ.GetProperties (instancePropertyFlags ||| BindingFlags.Public) |> orderTupleProperties) + Choice2Of2( + typ.GetProperties(instancePropertyFlags ||| BindingFlags.Public) + |> orderTupleProperties + ) let rec getTupleReader (typ: Type) = let etys = typ.GetGenericArguments() @@ -698,32 +874,37 @@ module internal Impl = let reader = match getTupleElementAccessors typ with | Choice1Of2 fi -> fun obj -> fi |> Array.map (fun f -> f.GetValue obj) - | Choice2Of2 pi -> fun obj -> pi |> Array.map (fun p -> p.GetValue (obj, null)) - if etys.Length < maxTuple - then reader + | Choice2Of2 pi -> fun obj -> pi |> Array.map (fun p -> p.GetValue(obj, null)) + + if etys.Length < maxTuple then + reader else let tyBenc = etys.[tupleEncField] let reader2 = getTupleReader tyBenc + (fun obj -> let directVals = reader obj let encVals = reader2 directVals.[tupleEncField] - Array.append directVals.[0..tupleEncField-1] encVals) + Array.append directVals.[0 .. tupleEncField - 1] encVals) let rec getTupleConstructor (typ: Type) = let etys = typ.GetGenericArguments() - let maker1 = getTupleCtor typ - if etys.Length < maxTuple - then maker1 + let maker1 = getTupleCtor typ + + if etys.Length < maxTuple then + maker1 else let tyBenc = etys.[tupleEncField] let maker2 = getTupleConstructor tyBenc + (fun (args: obj[]) -> let encVal = maker2 args.[tupleEncField..] - maker1 (Array.append args.[0..tupleEncField-1] [| encVal |])) + maker1 (Array.append args.[0 .. tupleEncField - 1] [| encVal |])) let getTupleConstructorInfo (typ: Type) = let etys = typ.GetGenericArguments() - let maker1 = getTupleConstructorMethod typ + let maker1 = getTupleConstructorMethod typ + if etys.Length < maxTuple then maker1, None else @@ -731,81 +912,115 @@ module internal Impl = let getTupleReaderInfo (typ: Type, index: int) = if index < 0 then - invalidArg "index" (String.Format (SR.GetString (SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + let msg = + String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString()) + + invalidArg "index" msg let get index = if typ.IsValueType then - let props = typ.GetProperties(instancePropertyFlags ||| BindingFlags.Public) |> orderTupleProperties + let props = + typ.GetProperties(instancePropertyFlags ||| BindingFlags.Public) + |> orderTupleProperties + if index >= props.Length then - invalidArg "index" (String.Format (SR.GetString (SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + let msg = + String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString()) + + invalidArg "index" msg + props.[index] else - let props = typ.GetProperties(instancePropertyFlags ||| BindingFlags.Public) |> orderTupleProperties + let props = + typ.GetProperties(instancePropertyFlags ||| BindingFlags.Public) + |> orderTupleProperties + if index >= props.Length then - invalidArg "index" (String.Format (SR.GetString (SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + let msg = + String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString()) + + invalidArg "index" msg + props.[index] if index < tupleEncField then get index, None else let etys = typ.GetGenericArguments() - get tupleEncField, Some(etys.[tupleEncField], index-(maxTuple-1)) + get tupleEncField, Some(etys.[tupleEncField], index - (maxTuple - 1)) let getFunctionTypeInfo (typ: Type) = - if not (isFunctionType typ) then - invalidArg "typ" (String.Format (SR.GetString (SR.notAFunctionType), typ.FullName)) - let tyargs = typ.GetGenericArguments() - tyargs.[0], tyargs.[1] + if not (isFunctionType typ) then + invalidArg "typ" (String.Format(SR.GetString(SR.notAFunctionType), typ.FullName)) + + let tyargs = typ.GetGenericArguments() + tyargs.[0], tyargs.[1] let isModuleType (typ: Type) = - match tryFindSourceConstructFlagsOfType typ with - | None -> false - | Some flags -> - (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Module + match tryFindSourceConstructFlagsOfType typ with + | None -> false + | Some flags -> (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Module let rec isClosureRepr typ = - isFunctionType typ || - (match typ.BaseType with null -> false | bty -> isClosureRepr bty) + isFunctionType typ + || (match typ.BaseType with + | null -> false + | bty -> isClosureRepr bty) let isRecordType (typ: Type, bindingFlags: BindingFlags) = - match tryFindSourceConstructFlagsOfType typ with - | None -> false - | Some flags -> - (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.RecordType && - // We see private representations only if BindingFlags.NonPublic is set - (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum 0 then - (bindingFlags &&& BindingFlags.NonPublic) <> enum 0 - else - true) - - let fieldPropsOfRecordType(typ: Type, bindingFlags) = - typ.GetProperties(instancePropertyFlags ||| bindingFlags) - |> Array.filter isFieldProperty - |> sortFreshArray (fun p1 p2 -> compare (sequenceNumberOfMember p1) (sequenceNumberOfMember p2)) - - let getRecordReader(typ: Type, bindingFlags) = - let props = fieldPropsOfRecordType(typ, bindingFlags) - (fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue (obj, null))) - - let getRecordReaderCompiled(typ: Type, bindingFlags) = - let props = fieldPropsOfRecordType(typ, bindingFlags) + match tryFindSourceConstructFlagsOfType typ with + | None -> false + | Some flags -> + (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.RecordType + && + // We see private representations only if BindingFlags.NonPublic is set + (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum 0 then + (bindingFlags &&& BindingFlags.NonPublic) <> enum 0 + else + true) + + let fieldPropsOfRecordType (typ: Type, bindingFlags) = + typ.GetProperties(instancePropertyFlags ||| bindingFlags) + |> Array.filter isFieldProperty + |> sortFreshArray (fun p1 p2 -> compare (sequenceNumberOfMember p1) (sequenceNumberOfMember p2)) + + let getRecordReader (typ: Type, bindingFlags) = + let props = fieldPropsOfRecordType (typ, bindingFlags) + (fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue(obj, null))) + + let getRecordReaderCompiled (typ: Type, bindingFlags) = + let props = fieldPropsOfRecordType (typ, bindingFlags) compileRecordOrUnionCaseReaderFunc(typ, props).Invoke - let getRecordConstructorMethod(typ: Type, bindingFlags) = - let props = fieldPropsOfRecordType(typ, bindingFlags) - let ctor = typ.GetConstructor(BindingFlags.Instance ||| bindingFlags, null, props |> Array.map (fun p -> p.PropertyType), null) + let getRecordConstructorMethod (typ: Type, bindingFlags) = + let props = fieldPropsOfRecordType (typ, bindingFlags) + + let ctor = + typ.GetConstructor( + BindingFlags.Instance ||| bindingFlags, + null, + props |> Array.map (fun p -> p.PropertyType), + null + ) + match ctor with - | null -> raise <| ArgumentException (String.Format (SR.GetString (SR.invalidRecordTypeConstructorNotDefined), typ.FullName)) + | null -> + let msg = + String.Format(SR.GetString(SR.invalidRecordTypeConstructorNotDefined), typ.FullName) + + raise (ArgumentException(msg)) | _ -> () + ctor - let getRecordConstructor(typ: Type, bindingFlags) = - let ctor = getRecordConstructorMethod(typ, bindingFlags) + let getRecordConstructor (typ: Type, bindingFlags) = + let ctor = getRecordConstructorMethod (typ, bindingFlags) + (fun (args: obj[]) -> - ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| bindingFlags, null, args, null)) + ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| bindingFlags, null, args, null)) - let getRecordConstructorCompiled(typ: Type, bindingFlags) = - let ctor = getRecordConstructorMethod(typ, bindingFlags) + let getRecordConstructorCompiled (typ: Type, bindingFlags) = + let ctor = getRecordConstructorMethod (typ, bindingFlags) compileRecordConstructorFunc(ctor).Invoke /// EXCEPTION DECOMPILATION @@ -815,20 +1030,31 @@ module internal Impl = match tryFindSourceConstructFlagsOfType typ with | None -> false | Some flags -> - ((flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Exception) && - // We see private representations only if BindingFlags.NonPublic is set - (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum 0 then - (bindingFlags &&& BindingFlags.NonPublic) <> enum 0 - else - true) + ((flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Exception) + && + // We see private representations only if BindingFlags.NonPublic is set + (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum 0 then + (bindingFlags &&& BindingFlags.NonPublic) <> enum 0 + else + true) let getTypeOfReprType (typ: Type, bindingFlags) = - if isExceptionRepr (typ, bindingFlags) then typ.BaseType - elif isConstructorRepr (typ, bindingFlags) then unionTypeOfUnionCaseType(typ, bindingFlags) + if isExceptionRepr (typ, bindingFlags) then + typ.BaseType + elif isConstructorRepr (typ, bindingFlags) then + unionTypeOfUnionCaseType (typ, bindingFlags) elif isClosureRepr typ then - let rec get (typ: Type) = if isFunctionType typ then typ else match typ.BaseType with null -> typ | b -> get b - get typ - else typ + let rec get (typ: Type) = + if isFunctionType typ then + typ + else + match typ.BaseType with + | null -> typ + | b -> get b + + get typ + else + typ //----------------------------------------------------------------- // CHECKING ROUTINES @@ -836,22 +1062,31 @@ module internal Impl = let checkExnType (exceptionType, bindingFlags) = if not (isExceptionRepr (exceptionType, bindingFlags)) then if isExceptionRepr (exceptionType, bindingFlags ||| BindingFlags.NonPublic) then - invalidArg "exceptionType" (String.Format (SR.GetString (SR.privateExceptionType), exceptionType.FullName)) + let msg = + String.Format(SR.GetString(SR.privateExceptionType), exceptionType.FullName) + + invalidArg "exceptionType" msg else - invalidArg "exceptionType" (String.Format (SR.GetString (SR.notAnExceptionType), exceptionType.FullName)) + let msg = String.Format(SR.GetString(SR.notAnExceptionType), exceptionType.FullName) + invalidArg "exceptionType" msg let checkRecordType (argName, recordType, bindingFlags) = checkNonNull argName recordType - if not (isRecordType (recordType, bindingFlags) ) then + + if not (isRecordType (recordType, bindingFlags)) then if isRecordType (recordType, bindingFlags ||| BindingFlags.NonPublic) then - invalidArg argName (String.Format (SR.GetString (SR.privateRecordType), recordType.FullName)) + let msg = String.Format(SR.GetString(SR.privateRecordType), recordType.FullName) + invalidArg argName msg else - invalidArg argName (String.Format (SR.GetString (SR.notARecordType), recordType.FullName)) + let msg = String.Format(SR.GetString(SR.notARecordType), recordType.FullName) + invalidArg argName msg - let checkTupleType(argName, (tupleType: Type)) = + let checkTupleType (argName, (tupleType: Type)) = checkNonNull argName tupleType + if not (isTupleType tupleType) then - invalidArg argName (String.Format (SR.GetString (SR.notATupleType), tupleType.FullName)) + let msg = String.Format(SR.GetString(SR.notATupleType), tupleType.FullName) + invalidArg argName msg [] type UnionCaseInfo(typ: System.Type, tag: int) = @@ -859,16 +1094,18 @@ type UnionCaseInfo(typ: System.Type, tag: int) = // Cache the tag -> name map let mutable names = None - let getMethInfo() = getUnionCaseConstructorMethod (typ, tag, BindingFlags.Public ||| BindingFlags.NonPublic) + let getMethInfo () = + getUnionCaseConstructorMethod (typ, tag, BindingFlags.Public ||| BindingFlags.NonPublic) member _.Name = match names with | None -> - let conv = getUnionTagConverter (typ, BindingFlags.Public ||| BindingFlags.NonPublic) + let conv = + getUnionTagConverter (typ, BindingFlags.Public ||| BindingFlags.NonPublic) + names <- Some conv conv tag - | Some conv -> - conv tag + | Some conv -> conv tag member _.DeclaringType = typ @@ -886,9 +1123,11 @@ type UnionCaseInfo(typ: System.Type, tag: int) = member _.Tag = tag - override x.ToString() = typ.Name + "." + x.Name + override x.ToString() = + typ.Name + "." + x.Name - override x.GetHashCode() = typ.GetHashCode() + tag + override x.GetHashCode() = + typ.GetHashCode() + tag override _.Equals(obj: obj) = match obj with @@ -907,74 +1146,94 @@ type FSharpType = checkNonNull "typ" typ isRecordType (typ, bindingFlags) - static member IsUnion (typ: Type, ?bindingFlags) = + static member IsUnion(typ: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "typ" typ let typ = getTypeOfReprType (typ, BindingFlags.Public ||| BindingFlags.NonPublic) isUnionType (typ, bindingFlags) - static member IsFunction (typ: Type) = + static member IsFunction(typ: Type) = checkNonNull "typ" typ let typ = getTypeOfReprType (typ, BindingFlags.Public ||| BindingFlags.NonPublic) isFunctionType typ - static member IsModule (typ: Type) = + static member IsModule(typ: Type) = checkNonNull "typ" typ isModuleType typ - static member MakeFunctionType (domain: Type, range: Type) = + static member MakeFunctionType(domain: Type, range: Type) = checkNonNull "domain" domain checkNonNull "range" range func.MakeGenericType [| domain; range |] - static member MakeTupleType (types: Type[]) = + static member MakeTupleType(types: Type[]) = checkNonNull "types" types // No assembly passed therefore just get framework local version of Tuple let asm = typeof.Assembly - if types |> Array.exists (function null -> true | _ -> false) then - invalidArg "types" (SR.GetString (SR.nullsNotAllowedInArray)) + + if types + |> Array.exists (function + | null -> true + | _ -> false) then + invalidArg "types" (SR.GetString(SR.nullsNotAllowedInArray)) + mkTupleType false asm types - static member MakeTupleType (asm: Assembly, types: Type[]) = + static member MakeTupleType(asm: Assembly, types: Type[]) = checkNonNull "types" types - if types |> Array.exists (function null -> true | _ -> false) then - invalidArg "types" (SR.GetString (SR.nullsNotAllowedInArray)) + + if types + |> Array.exists (function + | null -> true + | _ -> false) then + invalidArg "types" (SR.GetString(SR.nullsNotAllowedInArray)) + mkTupleType false asm types - static member MakeStructTupleType (asm: Assembly, types: Type[]) = + static member MakeStructTupleType(asm: Assembly, types: Type[]) = checkNonNull "types" types - if types |> Array.exists (function null -> true | _ -> false) then - invalidArg "types" (SR.GetString (SR.nullsNotAllowedInArray)) + + if types + |> Array.exists (function + | null -> true + | _ -> false) then + invalidArg "types" (SR.GetString(SR.nullsNotAllowedInArray)) + mkTupleType true asm types - static member GetTupleElements (tupleType: Type) = - checkTupleType("tupleType", tupleType) + static member GetTupleElements(tupleType: Type) = + checkTupleType ("tupleType", tupleType) getTupleTypeInfo tupleType - static member GetFunctionElements (functionType: Type) = + static member GetFunctionElements(functionType: Type) = checkNonNull "functionType" functionType - let functionType = getTypeOfReprType (functionType, BindingFlags.Public ||| BindingFlags.NonPublic) + + let functionType = + getTypeOfReprType (functionType, BindingFlags.Public ||| BindingFlags.NonPublic) + getFunctionTypeInfo functionType - static member GetRecordFields (recordType: Type, ?bindingFlags) = + static member GetRecordFields(recordType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkRecordType ("recordType", recordType, bindingFlags) - fieldPropsOfRecordType(recordType, bindingFlags) + fieldPropsOfRecordType (recordType, bindingFlags) - static member GetUnionCases (unionType: Type, ?bindingFlags) = + static member GetUnionCases(unionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "unionType" unionType let unionType = getTypeOfReprType (unionType, bindingFlags) checkUnionType (unionType, bindingFlags) - getUnionTypeTagNameMap(unionType, bindingFlags) |> Array.mapi (fun i _ -> UnionCaseInfo(unionType, i)) - static member IsExceptionRepresentation (exceptionType: Type, ?bindingFlags) = + getUnionTypeTagNameMap (unionType, bindingFlags) + |> Array.mapi (fun i _ -> UnionCaseInfo(unionType, i)) + + static member IsExceptionRepresentation(exceptionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "exceptionType" exceptionType isExceptionRepr (exceptionType, bindingFlags) - static member GetExceptionFields (exceptionType: Type, ?bindingFlags) = + static member GetExceptionFields(exceptionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "exceptionType" exceptionType checkExnType (exceptionType, bindingFlags) @@ -982,13 +1241,14 @@ type FSharpType = type DynamicFunction<'T1, 'T2>() = inherit FSharpFunc obj, obj>() + override _.Invoke(impl: obj -> obj) : obj = - box<('T1 -> 'T2)> (fun inp -> unbox<'T2>(impl (box<'T1>(inp)))) + box<('T1 -> 'T2)> (fun inp -> unbox<'T2> (impl (box<'T1> (inp)))) [] type FSharpValue = - static member MakeRecord (recordType: Type, values, ?bindingFlags) = + static member MakeRecord(recordType: Type, values, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkRecordType ("recordType", recordType, bindingFlags) getRecordConstructor (recordType, bindingFlags) values @@ -997,19 +1257,23 @@ type FSharpValue = checkNonNull "info" info checkNonNull "record" record let reprty = record.GetType() + if not (isRecordType (reprty, BindingFlags.Public ||| BindingFlags.NonPublic)) then - invalidArg "record" (SR.GetString (SR.objIsNotARecord)) - info.GetValue (record, null) + invalidArg "record" (SR.GetString(SR.objIsNotARecord)) + + info.GetValue(record, null) - static member GetRecordFields (record: obj, ?bindingFlags) = + static member GetRecordFields(record: obj, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "record" record let typ = record.GetType() + if not (isRecordType (typ, bindingFlags)) then - invalidArg "record" (SR.GetString (SR.objIsNotARecord)) + invalidArg "record" (SR.GetString(SR.objIsNotARecord)) + getRecordReader (typ, bindingFlags) record - static member PreComputeRecordFieldReader(info: PropertyInfo): obj -> obj = + static member PreComputeRecordFieldReader(info: PropertyInfo) : obj -> obj = checkNonNull "info" info compilePropGetterFunc(info).Invoke @@ -1026,64 +1290,80 @@ type FSharpValue = static member PreComputeRecordConstructorInfo(recordType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkRecordType ("recordType", recordType, bindingFlags) - getRecordConstructorMethod(recordType, bindingFlags) + getRecordConstructorMethod (recordType, bindingFlags) - static member MakeFunction(functionType: Type, implementation:(obj->obj)) = + static member MakeFunction(functionType: Type, implementation: (obj -> obj)) = checkNonNull "functionType" functionType + if not (isFunctionType functionType) then - invalidArg "functionType" (String.Format (SR.GetString (SR.notAFunctionType), functionType.FullName)) + let msg = String.Format(SR.GetString(SR.notAFunctionType), functionType.FullName) + invalidArg "functionType" msg + checkNonNull "implementation" implementation let domain, range = getFunctionTypeInfo functionType let dynCloMakerTy = typedefof> let saverTy = dynCloMakerTy.MakeGenericType [| domain; range |] let o = Activator.CreateInstance saverTy - let (f : (obj -> obj) -> obj) = downcast o + let (f: (obj -> obj) -> obj) = downcast o f implementation static member MakeTuple(tupleElements: obj[], tupleType: Type) = checkNonNull "tupleElements" tupleElements - checkTupleType("tupleType", tupleType) + checkTupleType ("tupleType", tupleType) getTupleConstructor tupleType tupleElements static member GetTupleFields(tuple: obj) = // argument name(s) used in error message checkNonNull "tuple" tuple let typ = tuple.GetType() - if not (isTupleType typ ) then - invalidArg "tuple" (String.Format (SR.GetString (SR.notATupleType), tuple.GetType().FullName)) + + if not (isTupleType typ) then + let msg = String.Format(SR.GetString(SR.notATupleType), tuple.GetType().FullName) + invalidArg "tuple" msg + getTupleReader typ tuple static member GetTupleField(tuple: obj, index: int) = // argument name(s) used in error message checkNonNull "tuple" tuple let typ = tuple.GetType() - if not (isTupleType typ ) then - invalidArg "tuple" (String.Format (SR.GetString (SR.notATupleType), tuple.GetType().FullName)) + + if not (isTupleType typ) then + let msg = String.Format(SR.GetString(SR.notATupleType), tuple.GetType().FullName) + invalidArg "tuple" msg + let fields = getTupleReader typ tuple + if index < 0 || index >= fields.Length then - invalidArg "index" (String.Format (SR.GetString (SR.tupleIndexOutOfRange), tuple.GetType().FullName, index.ToString())) + let msg = + String.Format(SR.GetString(SR.tupleIndexOutOfRange), tuple.GetType().FullName, index.ToString()) + + invalidArg "index" msg + fields.[index] - static member PreComputeTupleReader(tupleType: Type) : (obj -> obj[]) = - checkTupleType("tupleType", tupleType) + static member PreComputeTupleReader(tupleType: Type) : (obj -> obj[]) = + checkTupleType ("tupleType", tupleType) (compileTupleReader tupleEncField getTupleElementAccessors tupleType).Invoke static member PreComputeTuplePropertyInfo(tupleType: Type, index: int) = - checkTupleType("tupleType", tupleType) + checkTupleType ("tupleType", tupleType) getTupleReaderInfo (tupleType, index) static member PreComputeTupleConstructor(tupleType: Type) = - checkTupleType("tupleType", tupleType) - (compileTupleConstructor tupleEncField getTupleConstructorMethod tupleType).Invoke + checkTupleType ("tupleType", tupleType) + + (compileTupleConstructor tupleEncField getTupleConstructorMethod tupleType) + .Invoke static member PreComputeTupleConstructorInfo(tupleType: Type) = - checkTupleType("tupleType", tupleType) + checkTupleType ("tupleType", tupleType) getTupleConstructorInfo tupleType - static member MakeUnion(unionCase: UnionCaseInfo, args: obj [], ?bindingFlags) = + static member MakeUnion(unionCase: UnionCaseInfo, args: obj[], ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "unionCase" unionCase getUnionCaseConstructor (unionCase.DeclaringType, unionCase.Tag, bindingFlags) args - static member PreComputeUnionConstructor (unionCase: UnionCaseInfo, ?bindingFlags) = + static member PreComputeUnionConstructor(unionCase: UnionCaseInfo, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "unionCase" unionCase getUnionCaseConstructorCompiled (unionCase.DeclaringType, unionCase.Tag, bindingFlags) @@ -1095,15 +1375,16 @@ type FSharpValue = static member GetUnionFields(value: obj, unionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public + let ensureType (typ: Type, obj: obj) = - match typ with - | null -> - match obj with - | null -> invalidArg "obj" (SR.GetString (SR.objIsNullAndNoType)) - | _ -> obj.GetType() - | _ -> typ + match typ with + | null -> + match obj with + | null -> invalidArg "obj" (SR.GetString(SR.objIsNullAndNoType)) + | _ -> obj.GetType() + | _ -> typ - let unionType = ensureType(unionType, value) + let unionType = ensureType (unionType, value) checkNonNull "unionType" unionType let unionType = getTypeOfReprType (unionType, bindingFlags) @@ -1111,7 +1392,7 @@ type FSharpValue = checkUnionType (unionType, bindingFlags) let tag = getUnionTagReader (unionType, bindingFlags) value let flds = getUnionCaseRecordReader (unionType, tag, bindingFlags) value - UnionCaseInfo (unionType, tag), flds + UnionCaseInfo(unionType, tag), flds static member PreComputeUnionTagReader(unionType: Type, ?bindingFlags) : (obj -> int) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public @@ -1127,13 +1408,13 @@ type FSharpValue = checkUnionType (unionType, bindingFlags) getUnionTagMemberInfo (unionType, bindingFlags) - static member PreComputeUnionReader(unionCase: UnionCaseInfo, ?bindingFlags) : (obj -> obj[]) = + static member PreComputeUnionReader(unionCase: UnionCaseInfo, ?bindingFlags) : (obj -> obj[]) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "unionCase" unionCase let typ = unionCase.DeclaringType getUnionCaseRecordReaderCompiled (typ, unionCase.Tag, bindingFlags) - static member GetExceptionFields (exn: obj, ?bindingFlags) = + static member GetExceptionFields(exn: obj, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkNonNull "exn" exn let typ = exn.GetType() @@ -1144,80 +1425,84 @@ module FSharpReflectionExtensions = type FSharpType with - static member GetExceptionFields (exceptionType: Type, ?allowAccessToPrivateRepresentation) = + static member GetExceptionFields(exceptionType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpType.GetExceptionFields (exceptionType, bindingFlags) + FSharpType.GetExceptionFields(exceptionType, bindingFlags) static member IsExceptionRepresentation(exceptionType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpType.IsExceptionRepresentation (exceptionType, bindingFlags) + FSharpType.IsExceptionRepresentation(exceptionType, bindingFlags) - static member GetUnionCases (unionType: Type, ?allowAccessToPrivateRepresentation) = + static member GetUnionCases(unionType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpType.GetUnionCases (unionType, bindingFlags) + FSharpType.GetUnionCases(unionType, bindingFlags) - static member GetRecordFields (recordType: Type, ?allowAccessToPrivateRepresentation) = + static member GetRecordFields(recordType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpType.GetRecordFields (recordType, bindingFlags) + FSharpType.GetRecordFields(recordType, bindingFlags) - static member IsUnion (typ: Type, ?allowAccessToPrivateRepresentation) = + static member IsUnion(typ: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpType.IsUnion (typ, bindingFlags) + FSharpType.IsUnion(typ, bindingFlags) static member IsRecord(typ: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpType.IsRecord (typ, bindingFlags) + FSharpType.IsRecord(typ, bindingFlags) type FSharpValue with + static member MakeRecord(recordType: Type, values, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.MakeRecord (recordType, values, bindingFlags) + FSharpValue.MakeRecord(recordType, values, bindingFlags) - static member GetRecordFields (record: obj, ?allowAccessToPrivateRepresentation) = + static member GetRecordFields(record: obj, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.GetRecordFields (record, bindingFlags) + FSharpValue.GetRecordFields(record, bindingFlags) static member PreComputeRecordReader(recordType: Type, ?allowAccessToPrivateRepresentation) : (obj -> obj[]) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeRecordReader (recordType, bindingFlags) + FSharpValue.PreComputeRecordReader(recordType, bindingFlags) static member PreComputeRecordConstructor(recordType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeRecordConstructor (recordType, bindingFlags) + FSharpValue.PreComputeRecordConstructor(recordType, bindingFlags) static member PreComputeRecordConstructorInfo(recordType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeRecordConstructorInfo (recordType, bindingFlags) + FSharpValue.PreComputeRecordConstructorInfo(recordType, bindingFlags) - static member MakeUnion(unionCase: UnionCaseInfo, args: obj [], ?allowAccessToPrivateRepresentation) = + static member MakeUnion(unionCase: UnionCaseInfo, args: obj[], ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.MakeUnion (unionCase, args, bindingFlags) + FSharpValue.MakeUnion(unionCase, args, bindingFlags) - static member PreComputeUnionConstructor (unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) = + static member PreComputeUnionConstructor(unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionConstructor (unionCase, bindingFlags) + FSharpValue.PreComputeUnionConstructor(unionCase, bindingFlags) static member PreComputeUnionConstructorInfo(unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionConstructorInfo (unionCase, bindingFlags) + FSharpValue.PreComputeUnionConstructorInfo(unionCase, bindingFlags) static member PreComputeUnionTagMemberInfo(unionType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionTagMemberInfo (unionType, bindingFlags) + FSharpValue.PreComputeUnionTagMemberInfo(unionType, bindingFlags) static member GetUnionFields(value: obj, unionType: Type, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.GetUnionFields (value, unionType, bindingFlags) + FSharpValue.GetUnionFields(value, unionType, bindingFlags) static member PreComputeUnionTagReader(unionType: Type, ?allowAccessToPrivateRepresentation) : (obj -> int) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionTagReader (unionType, bindingFlags) + FSharpValue.PreComputeUnionTagReader(unionType, bindingFlags) - static member PreComputeUnionReader(unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) : (obj -> obj[]) = + static member PreComputeUnionReader + ( + unionCase: UnionCaseInfo, + ?allowAccessToPrivateRepresentation + ) : (obj -> obj[]) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionReader (unionCase, bindingFlags) + FSharpValue.PreComputeUnionReader(unionCase, bindingFlags) - static member GetExceptionFields (exn: obj, ?allowAccessToPrivateRepresentation) = + static member GetExceptionFields(exn: obj, ?allowAccessToPrivateRepresentation) = let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.GetExceptionFields (exn, bindingFlags) - + FSharpValue.GetExceptionFields(exn, bindingFlags) diff --git a/src/FSharp.Core/result.fs b/src/FSharp.Core/result.fs index ae9a7ca545a..1f82740fa5f 100644 --- a/src/FSharp.Core/result.fs +++ b/src/FSharp.Core/result.fs @@ -6,10 +6,19 @@ namespace Microsoft.FSharp.Core module Result = [] - let map mapping result = match result with Error e -> Error e | Ok x -> Ok (mapping x) + let map mapping result = + match result with + | Error e -> Error e + | Ok x -> Ok(mapping x) [] - let mapError mapping result = match result with Error e -> Error (mapping e) | Ok x -> Ok x + let mapError mapping result = + match result with + | Error e -> Error(mapping e) + | Ok x -> Ok x [] - let bind binder result = match result with Error e -> Error e | Ok x -> binder x + let bind binder result = + match result with + | Error e -> Error e + | Ok x -> binder x diff --git a/src/FSharp.Core/resumable.fs b/src/FSharp.Core/resumable.fs index 02b896f62fa..ee762d3bf17 100644 --- a/src/FSharp.Core/resumable.fs +++ b/src/FSharp.Core/resumable.fs @@ -20,9 +20,9 @@ open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Control open Microsoft.FSharp.Collections -[] +[] [] -type NoEagerConstraintApplicationAttribute() = +type NoEagerConstraintApplicationAttribute() = inherit System.Attribute() type IResumableStateMachine<'Data> = @@ -43,26 +43,28 @@ type ResumableStateMachine<'Data> = [] val mutable ResumptionDynamicInfo: ResumptionDynamicInfo<'Data> - interface IResumableStateMachine<'Data> with + interface IResumableStateMachine<'Data> with member sm.ResumptionPoint = sm.ResumptionPoint - member sm.Data with get() = sm.Data and set v = sm.Data <- v - interface IAsyncStateMachine with - + member sm.Data + with get () = sm.Data + and set v = sm.Data <- v + + interface IAsyncStateMachine with + // Used for dynamic execution. For "__stateMachine" it is replaced. - member sm.MoveNext() = + member sm.MoveNext() = sm.ResumptionDynamicInfo.MoveNext(&sm) // Used when dynamic execution. For "__stateMachine" it is replaced. - member sm.SetStateMachine(state) = + member sm.SetStateMachine(state) = sm.ResumptionDynamicInfo.SetStateMachine(&sm, state) and ResumptionFunc<'Data> = delegate of byref> -> bool -and [] - ResumptionDynamicInfo<'Data>(initial: ResumptionFunc<'Data>) = - member val ResumptionFunc: ResumptionFunc<'Data> = initial with get, set - member val ResumptionData: obj = null with get, set +and [] ResumptionDynamicInfo<'Data>(initial: ResumptionFunc<'Data>) = + member val ResumptionFunc: ResumptionFunc<'Data> = initial with get, set + member val ResumptionData: obj = null with get, set abstract MoveNext: machine: byref> -> unit abstract SetStateMachine: machine: byref> * machineState: IAsyncStateMachine -> unit @@ -78,33 +80,40 @@ type SetStateMachineMethodImpl<'Data> = delegate of byref = delegate of byref> -> 'Result [] -module StateMachineHelpers = +module StateMachineHelpers = /// Statically determines whether resumable code is being used [] let __useResumableCode<'T> : bool = false [] - let __debugPoint (_name: string) : unit = () + let __debugPoint (_name: string) : unit = + () [] - let __resumableEntry () : int option = - failwith "__resumableEntry should always be guarded by __useResumableCode and only used in valid state machine implementations" + let __resumableEntry () : int option = + failwith + "__resumableEntry should always be guarded by __useResumableCode and only used in valid state machine implementations" [] - let __resumeAt<'T> (programLabel: int) : 'T = + let __resumeAt<'T> (programLabel: int) : 'T = ignore programLabel - failwith "__resumeAt should always be guarded by __useResumableCode and only used in valid state machine implementations" + + failwith + "__resumeAt should always be guarded by __useResumableCode and only used in valid state machine implementations" [] - let __stateMachine<'Data, 'Result> - (moveNextMethod: MoveNextMethodImpl<'Data>) - (setStateMachineMethod: SetStateMachineMethodImpl<'Data>) - (afterCode: AfterCode<'Data, 'Result>): 'Result = + let __stateMachine<'Data, 'Result> + (moveNextMethod: MoveNextMethodImpl<'Data>) + (setStateMachineMethod: SetStateMachineMethodImpl<'Data>) + (afterCode: AfterCode<'Data, 'Result>) + : 'Result = ignore moveNextMethod ignore setStateMachineMethod ignore afterCode - failwith "__stateMachine should always be guarded by __useResumableCode and only used in valid state machine implementations" + + failwith + "__stateMachine should always be guarded by __useResumableCode and only used in valid state machine implementations" module ResumableCode = @@ -114,23 +123,28 @@ module ResumableCode = let inline GetResumptionFunc (sm: byref>) = sm.ResumptionDynamicInfo.ResumptionFunc - let inline Delay(f : unit -> ResumableCode<'Data, 'T>) : ResumableCode<'Data, 'T> = - ResumableCode<'Data, 'T>(fun sm -> (f()).Invoke(&sm)) + let inline Delay (f: unit -> ResumableCode<'Data, 'T>) : ResumableCode<'Data, 'T> = + ResumableCode<'Data, 'T>(fun sm -> (f ()).Invoke(&sm)) /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - let inline Zero() : ResumableCode<'Data, unit> = + let inline Zero () : ResumableCode<'Data, unit> = ResumableCode<'Data, unit>(fun sm -> true) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - let CombineDynamic(sm: byref>, code1: ResumableCode<'Data, unit>, code2: ResumableCode<'Data, 'T>) : bool = - if code1.Invoke(&sm) then + let CombineDynamic + ( + sm: byref>, + code1: ResumableCode<'Data, unit>, + code2: ResumableCode<'Data, 'T> + ) : bool = + if code1.Invoke(&sm) then code2.Invoke(&sm) else let rec resume (mf: ResumptionFunc<'Data>) = - ResumptionFunc<'Data>(fun sm -> - if mf.Invoke(&sm) then + ResumptionFunc<'Data>(fun sm -> + if mf.Invoke(&sm) then code2.Invoke(&sm) else sm.ResumptionDynamicInfo.ResumptionFunc <- (resume (GetResumptionFunc &sm)) @@ -142,131 +156,191 @@ module ResumableCode = /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - let inline Combine(code1: ResumableCode<'Data, unit>, code2: ResumableCode<'Data, 'T>) : ResumableCode<'Data, 'T> = + let inline Combine (code1: ResumableCode<'Data, unit>, code2: ResumableCode<'Data, 'T>) : ResumableCode<'Data, 'T> = ResumableCode<'Data, 'T>(fun sm -> if __useResumableCode then //-- RESUMABLE CODE START // NOTE: The code for code1 may contain await points! Resuming may branch directly // into this code! let __stack_fin = code1.Invoke(&sm) - if __stack_fin then + + if __stack_fin then code2.Invoke(&sm) else false - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END else CombineDynamic(&sm, code1, code2)) - let rec WhileDynamic (sm: byref>, condition: unit -> bool, body: ResumableCode<'Data,unit>) : bool = - if condition() then - if body.Invoke (&sm) then - WhileDynamic (&sm, condition, body) + let rec WhileDynamic + ( + sm: byref>, + condition: unit -> bool, + body: ResumableCode<'Data, unit> + ) : bool = + if condition () then + if body.Invoke(&sm) then + WhileDynamic(&sm, condition, body) else let rf = GetResumptionFunc &sm - sm.ResumptionDynamicInfo.ResumptionFunc <- (ResumptionFunc<'Data>(fun sm -> WhileBodyDynamicAux(&sm, condition, body, rf))) + + sm.ResumptionDynamicInfo.ResumptionFunc <- + (ResumptionFunc<'Data>(fun sm -> WhileBodyDynamicAux(&sm, condition, body, rf))) + false else true - and WhileBodyDynamicAux (sm: byref>, condition: unit -> bool, body: ResumableCode<'Data,unit>, rf: ResumptionFunc<_>) : bool = - if rf.Invoke (&sm) then - WhileDynamic (&sm, condition, body) + + and WhileBodyDynamicAux + ( + sm: byref>, + condition: unit -> bool, + body: ResumableCode<'Data, unit>, + rf: ResumptionFunc<_> + ) : bool = + if rf.Invoke(&sm) then + WhileDynamic(&sm, condition, body) else let rf = GetResumptionFunc &sm - sm.ResumptionDynamicInfo.ResumptionFunc <- (ResumptionFunc<'Data>(fun sm -> WhileBodyDynamicAux(&sm, condition, body, rf))) + + sm.ResumptionDynamicInfo.ResumptionFunc <- + (ResumptionFunc<'Data>(fun sm -> WhileBodyDynamicAux(&sm, condition, body, rf))) + false /// Builds a step that executes the body while the condition predicate is true. - let inline While ([] condition : unit -> bool, body : ResumableCode<'Data, unit>) : ResumableCode<'Data, unit> = + let inline While + ( + [] condition: unit -> bool, + body: ResumableCode<'Data, unit> + ) : ResumableCode<'Data, unit> = ResumableCode<'Data, unit>(fun sm -> - if __useResumableCode then + if __useResumableCode then //-- RESUMABLE CODE START - let mutable __stack_go = true - while __stack_go && condition() do + let mutable __stack_go = true + + while __stack_go && condition () do // NOTE: The body of the state machine code for 'while' may contain await points, so resuming // the code will branch directly into the expanded 'body', branching directly into the while loop let __stack_body_fin = body.Invoke(&sm) // If the body completed, we go back around the loop (__stack_go = true) // If the body yielded, we yield (__stack_go = false) __stack_go <- __stack_body_fin + __stack_go - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END else WhileDynamic(&sm, condition, body)) - let rec TryWithDynamic (sm: byref>, body: ResumableCode<'Data, 'T>, handler: exn -> ResumableCode<'Data, 'T>) : bool = + let rec TryWithDynamic + ( + sm: byref>, + body: ResumableCode<'Data, 'T>, + handler: exn -> ResumableCode<'Data, 'T> + ) : bool = try - if body.Invoke(&sm) then + if body.Invoke(&sm) then true else let rf = GetResumptionFunc &sm - sm.ResumptionDynamicInfo.ResumptionFunc <- (ResumptionFunc<'Data>(fun sm -> TryWithDynamic(&sm, ResumableCode<'Data,'T>(fun sm -> rf.Invoke(&sm)), handler))) + + sm.ResumptionDynamicInfo.ResumptionFunc <- + (ResumptionFunc<'Data>(fun sm -> + TryWithDynamic(&sm, ResumableCode<'Data, 'T>(fun sm -> rf.Invoke(&sm)), handler))) + false - with exn -> + with exn -> (handler exn).Invoke(&sm) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let inline TryWith (body: ResumableCode<'Data, 'T>, catch: exn -> ResumableCode<'Data, 'T>) : ResumableCode<'Data, 'T> = + let inline TryWith + ( + body: ResumableCode<'Data, 'T>, + catch: exn -> ResumableCode<'Data, 'T> + ) : ResumableCode<'Data, 'T> = ResumableCode<'Data, 'T>(fun sm -> - if __useResumableCode then + if __useResumableCode then //-- RESUMABLE CODE START let mutable __stack_fin = false let mutable __stack_caught = false let mutable __stack_savedExn = Unchecked.defaultof<_> + try // The try block may contain await points. let __stack_body_fin = body.Invoke(&sm) // If we make it to the assignment we prove we've made a step __stack_fin <- __stack_body_fin - with exn -> + with exn -> __stack_caught <- true __stack_savedExn <- exn - if __stack_caught then - // Place the catch code outside the catch block + if __stack_caught then + // Place the catch code outside the catch block (catch __stack_savedExn).Invoke(&sm) else __stack_fin - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END else TryWithDynamic(&sm, body, catch)) - let rec TryFinallyCompensateDynamic (sm: byref>, mf: ResumptionFunc<'Data>, savedExn: exn option) : bool = + let rec TryFinallyCompensateDynamic + ( + sm: byref>, + mf: ResumptionFunc<'Data>, + savedExn: exn option + ) : bool = let mutable fin = false fin <- mf.Invoke(&sm) + if fin then // reraise at the end of the finally block - match savedExn with + match savedExn with | None -> true | Some exn -> raise exn - else + else let rf = GetResumptionFunc &sm - sm.ResumptionDynamicInfo.ResumptionFunc <- (ResumptionFunc<'Data>(fun sm -> TryFinallyCompensateDynamic(&sm, rf, savedExn))) + + sm.ResumptionDynamicInfo.ResumptionFunc <- + (ResumptionFunc<'Data>(fun sm -> TryFinallyCompensateDynamic(&sm, rf, savedExn))) + false - let rec TryFinallyAsyncDynamic (sm: byref>, body: ResumableCode<'Data, 'T>, compensation: ResumableCode<'Data,unit>) : bool = + let rec TryFinallyAsyncDynamic + ( + sm: byref>, + body: ResumableCode<'Data, 'T>, + compensation: ResumableCode<'Data, unit> + ) : bool = let mutable fin = false let mutable savedExn = None + try fin <- body.Invoke(&sm) with exn -> - savedExn <- Some exn + savedExn <- Some exn fin <- true - if fin then + + if fin then TryFinallyCompensateDynamic(&sm, ResumptionFunc<'Data>(fun sm -> compensation.Invoke(&sm)), savedExn) else let rf = GetResumptionFunc &sm - sm.ResumptionDynamicInfo.ResumptionFunc <- (ResumptionFunc<'Data>(fun sm -> TryFinallyAsyncDynamic(&sm, ResumableCode<'Data,'T>(fun sm -> rf.Invoke(&sm)), compensation))) + + sm.ResumptionDynamicInfo.ResumptionFunc <- + (ResumptionFunc<'Data>(fun sm -> + TryFinallyAsyncDynamic(&sm, ResumableCode<'Data, 'T>(fun sm -> rf.Invoke(&sm)), compensation))) + false /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let inline TryFinally (body: ResumableCode<'Data, 'T>, compensation: ResumableCode<'Data,unit>) = + let inline TryFinally (body: ResumableCode<'Data, 'T>, compensation: ResumableCode<'Data, unit>) = ResumableCode<'Data, 'T>(fun sm -> - if __useResumableCode then + if __useResumableCode then //-- RESUMABLE CODE START let mutable __stack_fin = false + try let __stack_body_fin = body.Invoke(&sm) // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with @@ -274,24 +348,30 @@ module ResumableCode = __stack_fin <- __stack_body_fin with _exn -> let __stack_ignore = compensation.Invoke(&sm) - reraise() + reraise () - if __stack_fin then + if __stack_fin then let __stack_ignore = compensation.Invoke(&sm) () + __stack_fin - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END else - TryFinallyAsyncDynamic(&sm, body, ResumableCode<_,_>(fun sm -> compensation.Invoke(&sm)))) + TryFinallyAsyncDynamic(&sm, body, ResumableCode<_, _>(fun sm -> compensation.Invoke(&sm)))) /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let inline TryFinallyAsync (body: ResumableCode<'Data, 'T>, compensation: ResumableCode<'Data,unit>) : ResumableCode<'Data, 'T> = + let inline TryFinallyAsync + ( + body: ResumableCode<'Data, 'T>, + compensation: ResumableCode<'Data, unit> + ) : ResumableCode<'Data, 'T> = ResumableCode<'Data, 'T>(fun sm -> - if __useResumableCode then + if __useResumableCode then //-- RESUMABLE CODE START let mutable __stack_fin = false let mutable savedExn = None + try let __stack_body_fin = body.Invoke(&sm) // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with @@ -301,59 +381,67 @@ module ResumableCode = savedExn <- Some exn __stack_fin <- true - if __stack_fin then + if __stack_fin then let __stack_compensation_fin = compensation.Invoke(&sm) __stack_fin <- __stack_compensation_fin - if __stack_fin then - match savedExn with + if __stack_fin then + match savedExn with | None -> () | Some exn -> raise exn __stack_fin - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END else TryFinallyAsyncDynamic(&sm, body, compensation)) - let inline Using (resource : 'Resource, body : 'Resource -> ResumableCode<'Data, 'T>) : ResumableCode<'Data, 'T> when 'Resource :> IDisposable = + let inline Using + ( + resource: 'Resource, + body: 'Resource -> ResumableCode<'Data, 'T> + ) : ResumableCode<'Data, 'T> when 'Resource :> IDisposable = // A using statement is just a try/finally with the finally block disposing if non-null. TryFinally( ResumableCode<'Data, 'T>(fun sm -> (body resource).Invoke(&sm)), - ResumableCode<'Data,unit>(fun sm -> - if not (isNull (box resource)) then + ResumableCode<'Data, unit>(fun sm -> + if not (isNull (box resource)) then resource.Dispose() - true)) - let inline For (sequence : seq<'T>, body : 'T -> ResumableCode<'Data, unit>) : ResumableCode<'Data, unit> = + true) + ) + + let inline For (sequence: seq<'T>, body: 'T -> ResumableCode<'Data, unit>) : ResumableCode<'Data, unit> = // A for loop is just a using statement on the sequence's enumerator... - Using (sequence.GetEnumerator(), + Using( + sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. (fun e -> While( - (fun () -> + (fun () -> __debugPoint "ForLoop.InOrToKeyword" - e.MoveNext()), - ResumableCode<'Data, unit>(fun sm -> - (body e.Current).Invoke(&sm))))) + e.MoveNext()), + ResumableCode<'Data, unit>(fun sm -> (body e.Current).Invoke(&sm)) + )) + ) - let YieldDynamic (sm: byref>) : bool = + let YieldDynamic (sm: byref>) : bool = let cont = ResumptionFunc<'Data>(fun _sm -> true) sm.ResumptionDynamicInfo.ResumptionFunc <- cont false - let inline Yield () : ResumableCode<'Data, unit> = - ResumableCode<'Data, unit>(fun sm -> - if __useResumableCode then + let inline Yield () : ResumableCode<'Data, unit> = + ResumableCode<'Data, unit>(fun sm -> + if __useResumableCode then //-- RESUMABLE CODE START - match __resumableEntry() with + match __resumableEntry () with | Some contID -> sm.ResumptionPoint <- contID - //if verbose then printfn $"[{sm.Id}] Yield: returning false to indicate yield, contID = {contID}" + //if verbose then printfn $"[{sm.Id}] Yield: returning false to indicate yield, contID = {contID}" false | None -> - //if verbose then printfn $"[{sm.Id}] Yield: returning true to indicate post-yield" + //if verbose then printfn $"[{sm.Id}] Yield: returning true to indicate post-yield" true - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END else YieldDynamic(&sm)) diff --git a/src/FSharp.Core/seq.fs b/src/FSharp.Core/seq.fs index 27699c40abb..b04ecfa3ec8 100644 --- a/src/FSharp.Core/seq.fs +++ b/src/FSharp.Core/seq.fs @@ -22,19 +22,31 @@ module Internal = open Microsoft.FSharp.Collections.IEnumerator - let rec tryItem index (e : IEnumerator<'T>) = + let rec tryItem index (e: IEnumerator<'T>) = if not (e.MoveNext()) then None elif index = 0 then Some e.Current - else tryItem (index-1) e + else tryItem (index - 1) e - let rec nth index (e : IEnumerator<'T>) = + let rec nth index (e: IEnumerator<'T>) = if not (e.MoveNext()) then let shortBy = index + 1 - invalidArgFmt "index" + + invalidArgFmt + "index" "{0}\nseq was short by {1} {2}" - [|SR.GetString SR.notEnoughElements; shortBy; (if shortBy = 1 then "element" else "elements")|] - if index = 0 then e.Current - else nth (index - 1) e + [| + SR.GetString SR.notEnoughElements + shortBy + (if shortBy = 1 then + "element" + else + "elements") + |] + + if index = 0 then + e.Current + else + nth (index - 1) e [] type MapEnumeratorState = @@ -43,98 +55,114 @@ module Internal = | Finished [] - type MapEnumerator<'T> () = + type MapEnumerator<'T>() = let mutable state = NotStarted [] - val mutable private curr : 'T + val mutable private curr: 'T - member this.GetCurrent () = + member this.GetCurrent() = match state with - | NotStarted -> notStarted() - | Finished -> alreadyFinished() + | NotStarted -> notStarted () + | Finished -> alreadyFinished () | InProcess -> () + this.curr - abstract DoMoveNext : byref<'T> -> bool - abstract Dispose : unit -> unit + abstract DoMoveNext: byref<'T> -> bool + abstract Dispose: unit -> unit interface IEnumerator<'T> with member this.Current = this.GetCurrent() interface IEnumerator with - member this.Current = box(this.GetCurrent()) - member this.MoveNext () = + member this.Current = box (this.GetCurrent()) + + member this.MoveNext() = state <- InProcess + if this.DoMoveNext(&this.curr) then true else state <- Finished false - member _.Reset() = noReset() + + member _.Reset() = + noReset () interface System.IDisposable with - member this.Dispose() = this.Dispose() + member this.Dispose() = + this.Dispose() - let map f (e : IEnumerator<_>) : IEnumerator<_>= + let map f (e: IEnumerator<_>) : IEnumerator<_> = upcast { new MapEnumerator<_>() with - member _.DoMoveNext (curr : byref<_>) = + member _.DoMoveNext(curr: byref<_>) = if e.MoveNext() then curr <- f e.Current true else false - member _.Dispose() = e.Dispose() + + member _.Dispose() = + e.Dispose() } - let mapi f (e : IEnumerator<_>) : IEnumerator<_> = - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + let mapi f (e: IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (f) let mutable i = -1 + upcast { new MapEnumerator<_>() with member _.DoMoveNext curr = i <- i + 1 + if e.MoveNext() then curr <- f.Invoke(i, e.Current) true else false - member _.Dispose() = e.Dispose() + + member _.Dispose() = + e.Dispose() } - let map2 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) : IEnumerator<_>= - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + let map2 f (e1: IEnumerator<_>) (e2: IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (f) + upcast { new MapEnumerator<_>() with member _.DoMoveNext curr = let n1 = e1.MoveNext() let n2 = e2.MoveNext() + if n1 && n2 then curr <- f.Invoke(e1.Current, e2.Current) true else false - member _.Dispose() = + member _.Dispose() = try e1.Dispose() finally e2.Dispose() } - let mapi2 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) : IEnumerator<_> = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) + let mapi2 f (e1: IEnumerator<_>) (e2: IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (f) let mutable i = -1 + upcast { new MapEnumerator<_>() with member _.DoMoveNext curr = i <- i + 1 + if (e1.MoveNext() && e2.MoveNext()) then - curr <- f.Invoke(i, e1.Current, e2.Current) - true + curr <- f.Invoke(i, e1.Current, e2.Current) + true else - false + false member _.Dispose() = try @@ -143,8 +171,9 @@ module Internal = e2.Dispose() } - let map3 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) (e3 : IEnumerator<_>) : IEnumerator<_> = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) + let map3 f (e1: IEnumerator<_>) (e2: IEnumerator<_>) (e3: IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt (f) + upcast { new MapEnumerator<_>() with member _.DoMoveNext curr = @@ -168,79 +197,96 @@ module Internal = e3.Dispose() } - let choose f (e : IEnumerator<'T>) = + let choose f (e: IEnumerator<'T>) = let mutable started = false let mutable curr = None - let get() = + + let get () = check started - match curr with - | None -> alreadyFinished() + + match curr with + | None -> alreadyFinished () | Some x -> x { new IEnumerator<'U> with - member _.Current = get() - + member _.Current = get () interface IEnumerator with - member _.Current = box (get()) - member _.MoveNext() = - if not started then started <- true - curr <- None - while (curr.IsNone && e.MoveNext()) do - curr <- f e.Current - Option.isSome curr + member _.Current = box (get ()) + + member _.MoveNext() = + if not started then started <- true + curr <- None + + while (curr.IsNone && e.MoveNext()) do + curr <- f e.Current - member _.Reset() = noReset() + Option.isSome curr + member _.Reset() = + noReset () interface System.IDisposable with - member _.Dispose() = e.Dispose() } + member _.Dispose() = + e.Dispose() + } - let filter f (e : IEnumerator<'T>) = + let filter f (e: IEnumerator<'T>) = let mutable started = false + let this = { new IEnumerator<'T> with - member _.Current = check started; e.Current - + member _.Current = + check started + e.Current interface IEnumerator with - member _.Current = check started; box e.Current + member _.Current = + check started + box e.Current - member _.MoveNext() = - let rec next() = - if not started then started <- true - e.MoveNext() && (f e.Current || next()) - next() + member _.MoveNext() = + let rec next () = + if not started then started <- true + e.MoveNext() && (f e.Current || next ()) - member _.Reset() = noReset() + next () + member _.Reset() = + noReset () interface System.IDisposable with - member _.Dispose() = e.Dispose() } + member _.Dispose() = + e.Dispose() + } + this let unfold f x : IEnumerator<_> = let mutable state = x + upcast { new MapEnumerator<_>() with member _.DoMoveNext curr = match f state with | None -> false - | Some (r,s) -> + | Some (r, s) -> curr <- r state <- s true - member _.Dispose() = () + member _.Dispose() = + () } let upto lastOption f = match lastOption with - | Some b when b < 0 -> Empty() // a request for -ve length returns empty sequence + | Some b when b < 0 -> Empty() // a request for -ve length returns empty sequence | _ -> - let unstarted = -1 // index value means unstarted (and no valid index) - let completed = -2 // index value means completed (and no valid index) - let unreachable = -3 // index is unreachable from 0,1,2,3,... + let unstarted = -1 // index value means unstarted (and no valid index) + let completed = -2 // index value means completed (and no valid index) + let unreachable = -3 // index is unreachable from 0,1,2,3,... + let finalIndex = match lastOption with - | Some b -> b // here b>=0, a valid end value. - | None -> unreachable // run "forever", well as far as Int32.MaxValue since indexing with a bounded type. + | Some b -> b // here b>=0, a valid end value. + | None -> unreachable // run "forever", well as far as Int32.MaxValue since indexing with a bounded type. // The Current value for a valid index is "f i". // Lazy<_> values are used as caches, to store either the result or an exception if thrown. @@ -252,54 +298,64 @@ module Internal = // a Lazy node to cache the result/exception let mutable current = Unchecked.defaultof<_> + let setIndex i = index <- i current <- (Unchecked.defaultof<_>) // cache node unprimed, initialised on demand. - let getCurrent() = - if index = unstarted then notStarted() - if index = completed then alreadyFinished() + let getCurrent () = + if index = unstarted then notStarted () + + if index = completed then + alreadyFinished () + match box current with - | null -> - current <- Lazy<_>.Create(fun () -> f index) - | _ -> () + | null -> current <- Lazy<_>.Create (fun () -> f index) + | _ -> () // forced or re-forced immediately. current.Force() - { new IEnumerator<'U> with - member _.Current = getCurrent() + { new IEnumerator<'U> with + member _.Current = getCurrent () interface IEnumerator with - member _.Current = box (getCurrent()) - member _.MoveNext() = - if index = completed then - false - elif index = unstarted then - setIndex 0 - true - else - if index = System.Int32.MaxValue then invalidOp (SR.GetString(SR.enumerationPastIntMaxValue)) - if index = finalIndex then - false - else - setIndex (index + 1) - true - - member _.Reset() = noReset() - + member _.Current = box (getCurrent ()) + + member _.MoveNext() = + if index = completed then + false + elif index = unstarted then + setIndex 0 + true + else + if index = System.Int32.MaxValue then + invalidOp (SR.GetString(SR.enumerationPastIntMaxValue)) + + if index = finalIndex then + false + else + setIndex (index + 1) + true + + member _.Reset() = + noReset () interface System.IDisposable with - member _.Dispose() = () + member _.Dispose() = + () } [] type ArrayEnumerator<'T>(arr: 'T array) = let mutable curr = -1 let mutable len = arr.Length + member _.Get() = if curr >= 0 then - if curr >= len then alreadyFinished() - else arr.[curr] + if curr >= len then + alreadyFinished () + else + arr.[curr] else - notStarted() + notStarted () interface IEnumerator<'T> with member x.Current = x.Get() @@ -312,14 +368,17 @@ module Internal = curr <- curr + 1 curr < len - member x.Current = box(x.Get()) + member x.Current = box (x.Get()) - member _.Reset() = noReset() + member _.Reset() = + noReset () interface System.IDisposable with - member _.Dispose() = () + member _.Dispose() = + () - let ofArray arr = (new ArrayEnumerator<'T>(arr) :> IEnumerator<'T>) + let ofArray arr = + (new ArrayEnumerator<'T>(arr) :> IEnumerator<'T>) // Use generators for some implementations of IEnumerables. // @@ -335,18 +394,17 @@ module Internal = abstract Apply: (unit -> Step<'T>) abstract Disposer: (unit -> unit) option - let disposeG (g:Generator<'T>) = + let disposeG (g: Generator<'T>) = match g.Disposer with | None -> () - | Some f -> f() + | Some f -> f () - let appG (g:Generator<_>) = + let appG (g: Generator<_>) = let res = g.Apply() + match res with - | Goto next -> - Goto next - | Yield _ -> - res + | Goto next -> Goto next + | Yield _ -> res | Stop -> disposeG g res @@ -362,7 +420,7 @@ module Internal = // yield! rwalk (n-1) // yield n } - type GenerateThen<'T>(g:Generator<'T>, cont : unit -> Generator<'T>) = + type GenerateThen<'T>(g: Generator<'T>, cont: unit -> Generator<'T>) = member _.Generator = g @@ -370,27 +428,27 @@ module Internal = interface Generator<'T> with - member _.Apply = (fun () -> - match appG g with - | Stop -> - // OK, move onto the generator given by the continuation - Goto(cont()) + member _.Apply = + (fun () -> + match appG g with + | Stop -> + // OK, move onto the generator given by the continuation + Goto(cont ()) - | Yield _ as res -> - res + | Yield _ as res -> res - | Goto next -> - Goto(GenerateThen<_>.Bind(next, cont))) + | Goto next -> Goto(GenerateThen<_>.Bind (next, cont))) - member _.Disposer = - g.Disposer + member _.Disposer = g.Disposer - static member Bind (g:Generator<'T>, cont) = + static member Bind(g: Generator<'T>, cont) = match g with - | :? GenerateThen<'T> as g -> GenerateThen<_>.Bind(g.Generator, (fun () -> GenerateThen<_>.Bind (g.Cont(), cont))) + | :? GenerateThen<'T> as g -> + GenerateThen<_>.Bind (g.Generator, (fun () -> GenerateThen<_>.Bind (g.Cont(), cont))) | g -> (new GenerateThen<'T>(g, cont) :> Generator<'T>) - let bindG g cont = GenerateThen<_>.Bind(g,cont) + let bindG g cont = + GenerateThen<_>.Bind (g, cont) // Internal type. Drive an underlying generator. Crucially when the generator returns // a new generator we simply update our current generator and continue. Thus the enumerator @@ -414,7 +472,7 @@ module Internal = // and GenerateFromEnumerator. [] - type EnumeratorWrappingLazyGenerator<'T>(g:Generator<'T>) = + type EnumeratorWrappingLazyGenerator<'T>(g: Generator<'T>) = let mutable g = g let mutable curr = None let mutable finished = false @@ -422,66 +480,75 @@ module Internal = member _.Generator = g interface IEnumerator<'T> with - member _.Current = - match curr with - | Some v -> v + member _.Current = + match curr with + | Some v -> v | None -> invalidOp (SR.GetString(SR.moveNextNotCalledOrFinished)) interface System.Collections.IEnumerator with member x.Current = box (x :> IEnumerator<_>).Current member x.MoveNext() = - not finished && - match appG g with - | Stop -> - curr <- None - finished <- true - false - | Yield v -> - curr <- Some v - true - | Goto next -> - (g <- next) - (x :> IEnumerator).MoveNext() + not finished + && match appG g with + | Stop -> + curr <- None + finished <- true + false + | Yield v -> + curr <- Some v + true + | Goto next -> + (g <- next) + (x :> IEnumerator).MoveNext() - member _.Reset() = IEnumerator.noReset() + member _.Reset() = + IEnumerator.noReset () interface System.IDisposable with member _.Dispose() = if not finished then disposeG g // Internal type, used to optimize Enumerator/Generator chains - type LazyGeneratorWrappingEnumerator<'T>(e:IEnumerator<'T>) = + type LazyGeneratorWrappingEnumerator<'T>(e: IEnumerator<'T>) = member _.Enumerator = e + interface Generator<'T> with - member _.Apply = (fun () -> - if e.MoveNext() then - Yield e.Current - else - Stop) - member _.Disposer= Some e.Dispose + member _.Apply = + (fun () -> + if e.MoveNext() then + Yield e.Current + else + Stop) - let EnumerateFromGenerator(g:Generator<'T>) = + member _.Disposer = Some e.Dispose + + let EnumerateFromGenerator (g: Generator<'T>) = match g with | :? LazyGeneratorWrappingEnumerator<'T> as g -> g.Enumerator | _ -> (new EnumeratorWrappingLazyGenerator<'T>(g) :> IEnumerator<'T>) - let GenerateFromEnumerator (e:IEnumerator<'T>) = + let GenerateFromEnumerator (e: IEnumerator<'T>) = match e with - | :? EnumeratorWrappingLazyGenerator<'T> as e -> e.Generator + | :? EnumeratorWrappingLazyGenerator<'T> as e -> e.Generator | _ -> (new LazyGeneratorWrappingEnumerator<'T>(e) :> Generator<'T>) - [] -type CachedSeq<'T>(cleanup,res:seq<'T>) = +type CachedSeq<'T>(cleanup, res: seq<'T>) = interface System.IDisposable with - member x.Dispose() = cleanup() + member x.Dispose() = + cleanup () + interface System.Collections.Generic.IEnumerable<'T> with - member x.GetEnumerator() = res.GetEnumerator() + member x.GetEnumerator() = + res.GetEnumerator() + interface System.Collections.IEnumerable with - member x.GetEnumerator() = (res :> System.Collections.IEnumerable).GetEnumerator() - member obj.Clear() = cleanup() + member x.GetEnumerator() = + (res :> System.Collections.IEnumerable).GetEnumerator() + member obj.Clear() = + cleanup () [] [] @@ -490,137 +557,165 @@ module Seq = open Internal open IEnumerator - let mkDelayedSeq (f: unit -> IEnumerable<'T>) = mkSeq (fun () -> f().GetEnumerator()) - let mkUnfoldSeq f x = mkSeq (fun () -> IEnumerator.unfold f x) - let inline indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) + let mkDelayedSeq (f: unit -> IEnumerable<'T>) = + mkSeq (fun () -> f().GetEnumerator()) + + let mkUnfoldSeq f x = + mkSeq (fun () -> IEnumerator.unfold f x) + + let inline indexNotFound () = + raise (new System.Collections.Generic.KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) [] - let delay generator = mkDelayedSeq generator + let delay generator = + mkDelayedSeq generator [] - let unfold generator state = mkUnfoldSeq generator state + let unfold generator state = + mkUnfoldSeq generator state [] let empty<'T> = (EmptyEnumerable :> seq<'T>) [] - let initInfinite initializer = mkSeq (fun () -> IEnumerator.upto None initializer) + let initInfinite initializer = + mkSeq (fun () -> IEnumerator.upto None initializer) [] let init count initializer = - if count < 0 then invalidArgInputMustBeNonNegative "count" count - mkSeq (fun () -> IEnumerator.upto (Some (count - 1)) initializer) + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + + mkSeq (fun () -> IEnumerator.upto (Some(count - 1)) initializer) [] - let iter action (source : seq<'T>) = + let iter action (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() + while e.MoveNext() do action e.Current [] - let item index (source : seq<'T>) = + let item index (source: seq<'T>) = checkNonNull "source" source - if index < 0 then invalidArgInputMustBeNonNegative "index" index + + if index < 0 then + invalidArgInputMustBeNonNegative "index" index + use e = source.GetEnumerator() IEnumerator.nth index e [] - let tryItem index (source : seq<'T>) = + let tryItem index (source: seq<'T>) = checkNonNull "source" source - if index < 0 then None else - use e = source.GetEnumerator() - IEnumerator.tryItem index e + + if index < 0 then + None + else + use e = source.GetEnumerator() + IEnumerator.tryItem index e [] - let nth index (source : seq<'T>) = + let nth index (source: seq<'T>) = item index source [] - let iteri action (source : seq<'T>) = + let iteri action (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (action) let mutable i = 0 + while e.MoveNext() do f.Invoke(i, e.Current) i <- i + 1 [] - let exists predicate (source : seq<'T>) = + let exists predicate (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() let mutable state = false + while (not state && e.MoveNext()) do state <- predicate e.Current + state [] - let inline contains value (source : seq<'T>) = + let inline contains value (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() let mutable state = false + while (not state && e.MoveNext()) do state <- value = e.Current + state [] - let forall predicate (source : seq<'T>) = + let forall predicate (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() let mutable state = true + while (state && e.MoveNext()) do state <- predicate e.Current + state [] - let iter2 action (source1 : seq<_>) (source2 : seq<_>) = + let iter2 action (source1: seq<_>) (source2: seq<_>) = checkNonNull "source1" source1 checkNonNull "source2" source2 use e1 = source1.GetEnumerator() use e2 = source2.GetEnumerator() let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt action + while (e1.MoveNext() && e2.MoveNext()) do f.Invoke(e1.Current, e2.Current) [] - let iteri2 action (source1 : seq<_>) (source2 : seq<_>) = + let iteri2 action (source1: seq<_>) (source2: seq<_>) = checkNonNull "source1" source1 checkNonNull "source2" source2 use e1 = source1.GetEnumerator() use e2 = source2.GetEnumerator() let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt action let mutable i = 0 + while (e1.MoveNext() && e2.MoveNext()) do f.Invoke(i, e1.Current, e2.Current) i <- i + 1 // Build an IEnumerable by wrapping/transforming iterators as they get generated. - let revamp f (ie : seq<_>) = mkSeq (fun () -> f (ie.GetEnumerator())) + let revamp f (ie: seq<_>) = + mkSeq (fun () -> f (ie.GetEnumerator())) - let revamp2 f (ie1 : seq<_>) (source2 : seq<_>) = + let revamp2 f (ie1: seq<_>) (source2: seq<_>) = mkSeq (fun () -> f (ie1.GetEnumerator()) (source2.GetEnumerator())) - let revamp3 f (ie1 : seq<_>) (source2 : seq<_>) (source3 : seq<_>) = + let revamp3 f (ie1: seq<_>) (source2: seq<_>) (source3: seq<_>) = mkSeq (fun () -> f (ie1.GetEnumerator()) (source2.GetEnumerator()) (source3.GetEnumerator())) [] - let filter predicate source = + let filter predicate source = checkNonNull "source" source revamp (IEnumerator.filter predicate) source [] - let where predicate source = filter predicate source + let where predicate source = + filter predicate source [] - let map mapping source = + let map mapping source = checkNonNull "source" source revamp (IEnumerator.map mapping) source [] - let mapi mapping source = + let mapi mapping source = checkNonNull "source" source - revamp (IEnumerator.mapi mapping) source + revamp (IEnumerator.mapi mapping) source [] let mapi2 mapping source1 source2 = @@ -662,7 +757,7 @@ module Seq = checkNonNull "source1" source1 checkNonNull "source2" source2 checkNonNull "source3" source3 - map2 (fun x (y,z) -> x, y, z) source1 (zip source2 source3) + map2 (fun x (y, z) -> x, y, z) source1 (zip source2 source3) [] let cast (source: IEnumerable) = @@ -670,7 +765,7 @@ module Seq = mkSeq (fun () -> IEnumerator.cast (source.GetEnumerator())) [] - let tryPick chooser (source : seq<'T>) = + let tryPick chooser (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() let mutable res = None @@ -685,11 +780,11 @@ module Seq = checkNonNull "source" source match tryPick chooser source with - | None -> indexNotFound() + | None -> indexNotFound () | Some x -> x [] - let tryFind predicate (source : seq<'T>) = + let tryFind predicate (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() let mutable res = None @@ -705,27 +800,40 @@ module Seq = checkNonNull "source" source match tryFind predicate source with - | None -> indexNotFound() + | None -> indexNotFound () | Some x -> x [] - let take count (source : seq<'T>) = + let take count (source: seq<'T>) = checkNonNull "source" source - if count < 0 then invalidArgInputMustBeNonNegative "count" count + + if count < 0 then + invalidArgInputMustBeNonNegative "count" count // Note: don't create or dispose any IEnumerable if n = 0 if count = 0 then empty else - seq { use e = source.GetEnumerator() - for x in count .. - 1 .. 1 do - if not (e.MoveNext()) then - invalidOpFmt "{0}: tried to take {1} {2} past the end of the seq. Use Seq.truncate to get {3} or less elements" - [|SR.GetString SR.notEnoughElements; x; (if x = 1 then "element" else "elements"); count|] - yield e.Current } + seq { + use e = source.GetEnumerator() + + for x in count .. - 1 .. 1 do + if not (e.MoveNext()) then + invalidOpFmt + "{0}: tried to take {1} {2} past the end of the seq. Use Seq.truncate to get {3} or less elements" + [| + SR.GetString SR.notEnoughElements + x + (if x = 1 then "element" else "elements") + count + |] + + yield e.Current + } [] - let isEmpty (source : seq<'T>) = + let isEmpty (source: seq<'T>) = checkNonNull "source" source + match source with | :? ('T[]) as a -> a.Length = 0 | :? ('T list) as a -> a.IsEmpty @@ -734,15 +842,15 @@ module Seq = use ie = source.GetEnumerator() not (ie.MoveNext()) - [] let concat sources = checkNonNull "sources" sources RuntimeHelpers.mkConcatSeq sources [] - let length (source : seq<'T>) = + let length (source: seq<'T>) = checkNonNull "source" source + match source with | :? ('T[]) as a -> a.Length | :? ('T list) as a -> a.Length @@ -750,22 +858,26 @@ module Seq = | _ -> use e = source.GetEnumerator() let mutable state = 0 + while e.MoveNext() do state <- state + 1 + state [] - let fold<'T,'State> folder (state:'State) (source : seq<'T>) = + let fold<'T, 'State> folder (state: 'State) (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder let mutable state = state + while e.MoveNext() do state <- f.Invoke(state, e.Current) + state [] - let fold2<'T1,'T2,'State> folder (state:'State) (source1: seq<'T1>) (source2: seq<'T2>) = + let fold2<'T1, 'T2, 'State> folder (state: 'State) (source1: seq<'T1>) (source2: seq<'T2>) = checkNonNull "source1" source1 checkNonNull "source2" source2 @@ -775,75 +887,94 @@ module Seq = let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt folder let mutable state = state + while e1.MoveNext() && e2.MoveNext() do state <- f.Invoke(state, e1.Current, e2.Current) state [] - let reduce reduction (source : seq<'T>) = + let reduce reduction (source: seq<'T>) = checkNonNull "source" source use e = source.GetEnumerator() - if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + + if not (e.MoveNext()) then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt reduction let mutable state = e.Current + while e.MoveNext() do state <- f.Invoke(state, e.Current) + state - let fromGenerator f = mkSeq(fun () -> Generator.EnumerateFromGenerator (f())) - let toGenerator (ie : seq<_>) = Generator.GenerateFromEnumerator (ie.GetEnumerator()) + let fromGenerator f = + mkSeq (fun () -> Generator.EnumerateFromGenerator(f ())) + + let toGenerator (ie: seq<_>) = + Generator.GenerateFromEnumerator(ie.GetEnumerator()) [] let replicate count initial = - System.Linq.Enumerable.Repeat(initial,count) + System.Linq.Enumerable.Repeat(initial, count) [] let append (source1: seq<'T>) (source2: seq<'T>) = checkNonNull "source1" source1 checkNonNull "source2" source2 - fromGenerator(fun () -> Generator.bindG (toGenerator source1) (fun () -> toGenerator source2)) + fromGenerator (fun () -> Generator.bindG (toGenerator source1) (fun () -> toGenerator source2)) [] - let collect mapping source = map mapping source |> concat + let collect mapping source = + map mapping source |> concat [] - let compareWith (comparer:'T -> 'T -> int) (source1 : seq<'T>) (source2: seq<'T>) = + let compareWith (comparer: 'T -> 'T -> int) (source1: seq<'T>) (source2: seq<'T>) = checkNonNull "source1" source1 checkNonNull "source2" source2 use e1 = source1.GetEnumerator() use e2 = source2.GetEnumerator() let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt comparer + let rec go () = let e1ok = e1.MoveNext() let e2ok = e2.MoveNext() - let c = if e1ok = e2ok then 0 else if e1ok then 1 else -1 - if c <> 0 then c else - if not e1ok || not e2ok then 0 + + let c = + if e1ok = e2ok then 0 + else if e1ok then 1 + else -1 + + if c <> 0 then + c + else if not e1ok || not e2ok then + 0 else let c = f.Invoke(e1.Current, e2.Current) - if c <> 0 then c else - go () - go() + if c <> 0 then c else go () + + go () [] - let ofList (source : 'T list) = + let ofList (source: 'T list) = (source :> seq<'T>) [] - let toList (source : seq<'T>) = + let toList (source: seq<'T>) = checkNonNull "source" source Microsoft.FSharp.Primitives.Basics.List.ofSeq source // Create a new object to ensure underlying array may not be mutated by a backdoor cast [] - let ofArray (source : 'T array) = + let ofArray (source: 'T array) = checkNonNull "source" source mkSeq (fun () -> IEnumerator.ofArray source) [] - let toArray (source : seq<'T>) = + let toArray (source: seq<'T>) = checkNonNull "source" source + match source with | :? ('T[]) as res -> (res.Clone() :?> 'T[]) | :? ('T list) as res -> List.toArray res @@ -857,14 +988,16 @@ module Seq = let res = ResizeArray<_>(source) res.ToArray() - let foldArraySubRight (f:OptimizedClosures.FSharpFunc<'T,_,_>) (arr: 'T[]) start fin acc = + let foldArraySubRight (f: OptimizedClosures.FSharpFunc<'T, _, _>) (arr: 'T[]) start fin acc = let mutable state = acc + for i = fin downto start do state <- f.Invoke(arr.[i], state) + state [] - let foldBack<'T,'State> folder (source : seq<'T>) (state:'State) = + let foldBack<'T, 'State> folder (source: seq<'T>) (state: 'State) = checkNonNull "source" source let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder let arr = toArray source @@ -872,14 +1005,15 @@ module Seq = foldArraySubRight f arr 0 (len - 1) state [] - let foldBack2<'T1,'T2,'State> folder (source1 : seq<'T1>) (source2 : seq<'T2>) (state:'State) = + let foldBack2<'T1, 'T2, 'State> folder (source1: seq<'T1>) (source2: seq<'T2>) (state: 'State) = let zipped = zip source1 source2 foldBack ((<||) folder) zipped state [] - let reduceBack reduction (source : seq<'T>) = + let reduceBack reduction (source: seq<'T>) = checkNonNull "source" source let arr = toArray source + match arr.Length with | 0 -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString | len -> @@ -887,42 +1021,58 @@ module Seq = foldArraySubRight f arr 0 (len - 2) arr.[len - 1] [] - let singleton value = mkSeq (fun () -> IEnumerator.Singleton value) + let singleton value = + mkSeq (fun () -> IEnumerator.Singleton value) [] let truncate count (source: seq<'T>) = checkNonNull "source" source - if count <= 0 then empty else - seq { let mutable i = 0 - use ie = source.GetEnumerator() - while i < count && ie.MoveNext() do - i <- i + 1 - yield ie.Current } + + if count <= 0 then + empty + else + seq { + let mutable i = 0 + use ie = source.GetEnumerator() + + while i < count && ie.MoveNext() do + i <- i + 1 + yield ie.Current + } [] let pairwise (source: seq<'T>) = checkNonNull "source" source - seq { use ie = source.GetEnumerator() - if ie.MoveNext() then - let mutable iref = ie.Current - while ie.MoveNext() do - let j = ie.Current - yield (iref, j) - iref <- j } + + seq { + use ie = source.GetEnumerator() + + if ie.MoveNext() then + let mutable iref = ie.Current + + while ie.MoveNext() do + let j = ie.Current + yield (iref, j) + iref <- j + } [] - let scan<'T,'State> folder (state:'State) (source : seq<'T>) = + let scan<'T, 'State> folder (state: 'State) (source: seq<'T>) = checkNonNull "source" source let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder - seq { let mutable zref = state - yield zref - use ie = source.GetEnumerator() - while ie.MoveNext() do - zref <- f.Invoke(zref, ie.Current) - yield zref } + + seq { + let mutable zref = state + yield zref + use ie = source.GetEnumerator() + + while ie.MoveNext() do + zref <- f.Invoke(zref, ie.Current) + yield zref + } [] - let tryFindBack predicate (source : seq<'T>) = + let tryFindBack predicate (source: seq<'T>) = checkNonNull "source" source source |> toArray |> Array.tryFindBack predicate @@ -932,41 +1082,48 @@ module Seq = source |> toArray |> Array.findBack predicate [] - let scanBack<'T,'State> folder (source : seq<'T>) (state:'State) = + let scanBack<'T, 'State> folder (source: seq<'T>) (state: 'State) = checkNonNull "source" source - mkDelayedSeq(fun () -> + + mkDelayedSeq (fun () -> let arr = source |> toArray let res = Array.scanSubRight folder arr 0 (arr.Length - 1) state res :> seq<_>) [] - let findIndex predicate (source:seq<_>) = + let findIndex predicate (source: seq<_>) = checkNonNull "source" source use ie = source.GetEnumerator() + let rec loop i = if ie.MoveNext() then if predicate ie.Current then i - else loop (i + 1) + else + loop (i + 1) else - indexNotFound() + indexNotFound () + loop 0 [] - let tryFindIndex predicate (source:seq<_>) = + let tryFindIndex predicate (source: seq<_>) = checkNonNull "source" source use ie = source.GetEnumerator() + let rec loop i = if ie.MoveNext() then if predicate ie.Current then Some i - else loop (i + 1) + else + loop (i + 1) else None + loop 0 [] - let tryFindIndexBack predicate (source : seq<'T>) = + let tryFindIndexBack predicate (source: seq<'T>) = checkNonNull "source" source source |> toArray |> Array.tryFindIndexBack predicate @@ -979,29 +1136,34 @@ module Seq = [] let windowed windowSize (source: seq<_>) = checkNonNull "source" source - if windowSize <= 0 then invalidArgFmt "windowSize" "{0}\nwindowSize = {1}" - [|SR.GetString SR.inputMustBePositive; windowSize|] + + if windowSize <= 0 then + invalidArgFmt "windowSize" "{0}\nwindowSize = {1}" [| SR.GetString SR.inputMustBePositive; windowSize |] + seq { let arr = Array.zeroCreateUnchecked windowSize - let mutable r =windowSize - 1 + let mutable r = windowSize - 1 let mutable i = 0 use e = source.GetEnumerator() + while e.MoveNext() do arr.[i] <- e.Current i <- (i + 1) % windowSize + if r = 0 then if windowSize < 32 then - yield Array.init windowSize (fun j -> arr.[(i+j) % windowSize]) + yield Array.init windowSize (fun j -> arr.[(i + j) % windowSize]) else let result = Array.zeroCreateUnchecked windowSize Array.Copy(arr, i, result, 0, windowSize - i) Array.Copy(arr, 0, result, windowSize - i, i) yield result - else r <- (r - 1) + else + r <- (r - 1) } [] - let cache (source : seq<'T>) = + let cache (source: seq<'T>) = checkNonNull "source" source // Wrap a seq to ensure that it is enumerated just once and only as far as is necessary. // @@ -1012,7 +1174,7 @@ module Seq = // The state is (prefix,enumerator) with invariants: // * the prefix followed by elts from the enumerator are the initial sequence. // * the prefix contains only as many elements as the longest enumeration so far. - let prefix = ResizeArray<_>() + let prefix = ResizeArray<_>() // None = Unstarted. // Some(Some e) = Started. @@ -1020,49 +1182,54 @@ module Seq = let mutable enumeratorR = None let oneStepTo i = - // If possible, step the enumeration to prefix length i (at most one step). - // Be speculative, since this could have already happened via another thread. - if i >= prefix.Count then // is a step still required? - // If not yet started, start it (create enumerator). - let optEnumerator = - match enumeratorR with - | None -> - let optEnumerator = Some (source.GetEnumerator()) - enumeratorR <- Some optEnumerator - optEnumerator - | Some optEnumerator -> - optEnumerator - - match optEnumerator with - | Some enumerator -> - if enumerator.MoveNext() then - prefix.Add(enumerator.Current) - else - enumerator.Dispose() // Move failed, dispose enumerator, - enumeratorR <- Some None // drop it and record finished. - | None -> () + // If possible, step the enumeration to prefix length i (at most one step). + // Be speculative, since this could have already happened via another thread. + if i >= prefix.Count then // is a step still required? + // If not yet started, start it (create enumerator). + let optEnumerator = + match enumeratorR with + | None -> + let optEnumerator = Some(source.GetEnumerator()) + enumeratorR <- Some optEnumerator + optEnumerator + | Some optEnumerator -> optEnumerator + + match optEnumerator with + | Some enumerator -> + if enumerator.MoveNext() then + prefix.Add(enumerator.Current) + else + enumerator.Dispose() // Move failed, dispose enumerator, + enumeratorR <- Some None // drop it and record finished. + | None -> () let result = - unfold (fun i -> - // i being the next position to be returned - // A lock is needed over the reads to prefix.Count since the list may be being resized - // NOTE: we could change to a reader/writer lock here - lock prefix (fun () -> - if i < prefix.Count then - Some (prefix.[i],i+1) - else - oneStepTo i + unfold + (fun i -> + // i being the next position to be returned + // A lock is needed over the reads to prefix.Count since the list may be being resized + // NOTE: we could change to a reader/writer lock here + lock prefix (fun () -> if i < prefix.Count then - Some (prefix.[i],i+1) + Some(prefix.[i], i + 1) else - None)) 0 - let cleanup() = - lock prefix (fun () -> - prefix.Clear() - match enumeratorR with - | Some (Some e) -> IEnumerator.dispose e - | _ -> () - enumeratorR <- None) + oneStepTo i + + if i < prefix.Count then + Some(prefix.[i], i + 1) + else + None)) + 0 + + let cleanup () = + lock prefix (fun () -> + prefix.Clear() + + match enumeratorR with + | Some (Some e) -> IEnumerator.dispose e + | _ -> () + + enumeratorR <- None) (new CachedSeq<_>(cleanup, result) :> seq<_>) @@ -1074,14 +1241,19 @@ module Seq = source1 |> collect (fun x -> cached |> map (fun y -> x, y)) [] - let readonly (source:seq<_>) = + let readonly (source: seq<_>) = checkNonNull "source" source mkSeq (fun () -> source.GetEnumerator()) - let inline groupByImpl (comparer:IEqualityComparer<'SafeKey>) ([] keyf:'T->'SafeKey) ([] getKey:'SafeKey->'Key) (seq:seq<'T>) = + let inline groupByImpl + (comparer: IEqualityComparer<'SafeKey>) + ([] keyf: 'T -> 'SafeKey) + ([] getKey: 'SafeKey -> 'Key) + (seq: seq<'T>) + = checkNonNull "seq" seq - let dict = Dictionary<_,ResizeArray<_>> comparer + let dict = Dictionary<_, ResizeArray<_>> comparer // Previously this was 1, but I think this is rather stingy, considering that we are already paying // for at least a key, the ResizeArray reference, which includes an array reference, an Entry in the @@ -1089,63 +1261,80 @@ module Seq = let minimumBucketSize = 4 // Build the groupings - seq |> iter (fun v -> + seq + |> iter (fun v -> let safeKey = keyf v let mutable prev = Unchecked.defaultof<_> - match dict.TryGetValue (safeKey, &prev) with + + match dict.TryGetValue(safeKey, &prev) with | true -> prev.Add v | false -> - let prev = ResizeArray () + let prev = ResizeArray() dict.[safeKey] <- prev prev.Add v) // Trim the size of each result group, don't trim very small buckets, as excessive work, and garbage for // minimal gain - dict |> iter (fun group -> if group.Value.Count > minimumBucketSize then group.Value.TrimExcess()) + dict + |> iter (fun group -> + if group.Value.Count > minimumBucketSize then + group.Value.TrimExcess()) // Return the sequence-of-sequences. Don't reveal the // internal collections: just reveal them as sequences dict |> map (fun group -> (getKey group.Key, readonly group.Value)) // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let groupByValueType (keyf:'T->'Key) (seq:seq<'T>) = seq |> groupByImpl HashIdentity.Structural<'Key> keyf id + let groupByValueType (keyf: 'T -> 'Key) (seq: seq<'T>) = + seq |> groupByImpl HashIdentity.Structural<'Key> keyf id // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let groupByRefType (keyf:'T->'Key) (seq:seq<'T>) = seq |> groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) + let groupByRefType (keyf: 'T -> 'Key) (seq: seq<'T>) = + seq + |> groupByImpl + RuntimeHelpers.StructBox<'Key>.Comparer + (fun t -> RuntimeHelpers.StructBox(keyf t)) + (fun sb -> sb.Value) [] - let groupBy (projection:'T->'Key) (source:seq<'T>) = - if typeof<'Key>.IsValueType - then mkDelayedSeq (fun () -> groupByValueType projection source) - else mkDelayedSeq (fun () -> groupByRefType projection source) + let groupBy (projection: 'T -> 'Key) (source: seq<'T>) = + if typeof<'Key>.IsValueType then + mkDelayedSeq (fun () -> groupByValueType projection source) + else + mkDelayedSeq (fun () -> groupByRefType projection source) [] let transpose (source: seq<#seq<'T>>) = checkNonNull "source" source - source - |> collect indexed - |> groupBy fst - |> map (snd >> (map snd)) + source |> collect indexed |> groupBy fst |> map (snd >> (map snd)) [] let distinct source = checkNonNull "source" source - seq { let hashSet = HashSet<'T>(HashIdentity.Structural<'T>) - for v in source do - if hashSet.Add v then - yield v } + + seq { + let hashSet = HashSet<'T>(HashIdentity.Structural<'T>) + + for v in source do + if hashSet.Add v then yield v + } [] let distinctBy projection source = checkNonNull "source" source - seq { let hashSet = HashSet<_>(HashIdentity.Structural<_>) - for v in source do + + seq { + let hashSet = HashSet<_>(HashIdentity.Structural<_>) + + for v in source do if hashSet.Add(projection v) then - yield v } + yield v + } [] let sortBy projection source = checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray Array.stableSortInPlaceBy projection array @@ -1154,6 +1343,7 @@ module Seq = [] let sort source = checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray Array.stableSortInPlace array @@ -1162,6 +1352,7 @@ module Seq = [] let sortWith comparer source = checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray Array.stableSortInPlaceWith comparer array @@ -1170,175 +1361,243 @@ module Seq = [] let inline sortByDescending projection source = checkNonNull "source" source - let inline compareDescending a b = compare (projection b) (projection a) + + let inline compareDescending a b = + compare (projection b) (projection a) + sortWith compareDescending source [] let inline sortDescending source = checkNonNull "source" source - let inline compareDescending a b = compare b a + + let inline compareDescending a b = + compare b a + sortWith compareDescending source - let inline countByImpl (comparer:IEqualityComparer<'SafeKey>) ([] keyf:'T->'SafeKey) ([] getKey:'SafeKey->'Key) (source:seq<'T>) = + let inline countByImpl + (comparer: IEqualityComparer<'SafeKey>) + ([] keyf: 'T -> 'SafeKey) + ([] getKey: 'SafeKey -> 'Key) + (source: seq<'T>) + = checkNonNull "source" source let dict = Dictionary comparer // Build the groupings - source |> iter (fun v -> + source + |> iter (fun v -> let safeKey = keyf v let mutable prev = Unchecked.defaultof<_> - if dict.TryGetValue(safeKey, &prev) - then dict.[safeKey] <- prev + 1 - else dict.[safeKey] <- 1) + + if dict.TryGetValue(safeKey, &prev) then + dict.[safeKey] <- prev + 1 + else + dict.[safeKey] <- 1) dict |> map (fun group -> (getKey group.Key, group.Value)) // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let countByValueType (keyf:'T->'Key) (seq:seq<'T>) = seq |> countByImpl HashIdentity.Structural<'Key> keyf id + let countByValueType (keyf: 'T -> 'Key) (seq: seq<'T>) = + seq |> countByImpl HashIdentity.Structural<'Key> keyf id // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let countByRefType (keyf:'T->'Key) (seq:seq<'T>) = seq |> countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) + let countByRefType (keyf: 'T -> 'Key) (seq: seq<'T>) = + seq + |> countByImpl + RuntimeHelpers.StructBox<'Key>.Comparer + (fun t -> RuntimeHelpers.StructBox(keyf t)) + (fun sb -> sb.Value) [] - let countBy (projection:'T->'Key) (source:seq<'T>) = + let countBy (projection: 'T -> 'Key) (source: seq<'T>) = checkNonNull "source" source - if typeof<'Key>.IsValueType - then mkDelayedSeq (fun () -> countByValueType projection source) - else mkDelayedSeq (fun () -> countByRefType projection source) + if typeof<'Key>.IsValueType then + mkDelayedSeq (fun () -> countByValueType projection source) + else + mkDelayedSeq (fun () -> countByRefType projection source) [] - let inline sum (source: seq< ^a>) : ^a = + let inline sum (source: seq< ^a >) : ^a = use e = source.GetEnumerator() let mutable acc = LanguagePrimitives.GenericZero< ^a> + while e.MoveNext() do acc <- Checked.(+) acc e.Current + acc [] - let inline sumBy ([] projection : 'T -> ^U) (source: seq<'T>) : ^U = + let inline sumBy ([] projection: 'T -> ^U) (source: seq<'T>) : ^U = use e = source.GetEnumerator() let mutable acc = LanguagePrimitives.GenericZero< ^U> + while e.MoveNext() do acc <- Checked.(+) acc (projection e.Current) + acc [] - let inline average (source: seq< ^a>) : ^a = + let inline average (source: seq< ^a >) : ^a = checkNonNull "source" source use e = source.GetEnumerator() let mutable acc = LanguagePrimitives.GenericZero< ^a> let mutable count = 0 + while e.MoveNext() do acc <- Checked.(+) acc e.Current count <- count + 1 + if count = 0 then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + LanguagePrimitives.DivideByInt< ^a> acc count [] - let inline averageBy ([] projection : 'T -> ^U) (source: seq<'T>) : ^U = + let inline averageBy ([] projection: 'T -> ^U) (source: seq<'T>) : ^U = checkNonNull "source" source use e = source.GetEnumerator() let mutable acc = LanguagePrimitives.GenericZero< ^U> let mutable count = 0 + while e.MoveNext() do acc <- Checked.(+) acc (projection e.Current) count <- count + 1 + if count = 0 then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + LanguagePrimitives.DivideByInt< ^U> acc count [] let inline min (source: seq<_>) = checkNonNull "source" source use e = source.GetEnumerator() + if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let mutable acc = e.Current + while e.MoveNext() do let curr = e.Current - if curr < acc then - acc <- curr + if curr < acc then acc <- curr + acc [] - let inline minBy (projection : 'T -> 'U) (source: seq<'T>) : 'T = + let inline minBy (projection: 'T -> 'U) (source: seq<'T>) : 'T = checkNonNull "source" source use e = source.GetEnumerator() + if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let first = e.Current let mutable acc = projection first let mutable accv = first + while e.MoveNext() do let currv = e.Current let curr = projection currv + if curr < acc then acc <- curr accv <- currv + accv [] let inline max (source: seq<_>) = checkNonNull "source" source use e = source.GetEnumerator() + if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let mutable acc = e.Current + while e.MoveNext() do let curr = e.Current - if curr > acc then - acc <- curr + if curr > acc then acc <- curr + acc [] - let inline maxBy (projection : 'T -> 'U) (source: seq<'T>) : 'T = + let inline maxBy (projection: 'T -> 'U) (source: seq<'T>) : 'T = checkNonNull "source" source use e = source.GetEnumerator() + if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let first = e.Current let mutable acc = projection first let mutable accv = first + while e.MoveNext() do let currv = e.Current let curr = projection currv + if curr > acc then acc <- curr accv <- currv + accv [] let takeWhile predicate (source: seq<_>) = checkNonNull "source" source - seq { use e = source.GetEnumerator() - let mutable latest = Unchecked.defaultof<_> - while e.MoveNext() && (latest <- e.Current; predicate latest) do - yield latest } + + seq { + use e = source.GetEnumerator() + let mutable latest = Unchecked.defaultof<_> + + while e.MoveNext() + && (latest <- e.Current + predicate latest) do + yield latest + } [] let skip count (source: seq<_>) = checkNonNull "source" source - seq { use e = source.GetEnumerator() - for x in 1 .. count do - if not (e.MoveNext()) then - invalidOpFmt "tried to skip {0} {1} past the end of the seq" - [|SR.GetString SR.notEnoughElements; x; (if x=1 then "element" else "elements")|] - while e.MoveNext() do - yield e.Current } + + seq { + use e = source.GetEnumerator() + + for x in 1..count do + if not (e.MoveNext()) then + invalidOpFmt + "tried to skip {0} {1} past the end of the seq" + [| + SR.GetString SR.notEnoughElements + x + (if x = 1 then "element" else "elements") + |] + + while e.MoveNext() do + yield e.Current + } [] let skipWhile predicate (source: seq<_>) = checkNonNull "source" source - seq { use e = source.GetEnumerator() - let mutable latest = Unchecked.defaultof<_> - let mutable ok = false - while e.MoveNext() do - if (latest <- e.Current; (ok || not (predicate latest))) then - ok <- true - yield latest } + + seq { + use e = source.GetEnumerator() + let mutable latest = Unchecked.defaultof<_> + let mutable ok = false + + while e.MoveNext() do + if (latest <- e.Current + (ok || not (predicate latest))) then + ok <- true + yield latest + } [] let forall2 predicate (source1: seq<_>) (source2: seq<_>) = @@ -1346,10 +1605,12 @@ module Seq = checkNonNull "source2" source2 use e1 = source1.GetEnumerator() use e2 = source2.GetEnumerator() - let p = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate + let p = OptimizedClosures.FSharpFunc<_, _, _>.Adapt predicate let mutable ok = true + while (ok && e1.MoveNext() && e2.MoveNext()) do ok <- p.Invoke(e1.Current, e2.Current) + ok [] @@ -1358,55 +1619,72 @@ module Seq = checkNonNull "source2" source2 use e1 = source1.GetEnumerator() use e2 = source2.GetEnumerator() - let p = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate + let p = OptimizedClosures.FSharpFunc<_, _, _>.Adapt predicate let mutable ok = false + while (not ok && e1.MoveNext() && e2.MoveNext()) do ok <- p.Invoke(e1.Current, e2.Current) + ok [] - let head (source : seq<_>) = + let head (source: seq<_>) = checkNonNull "source" source use e = source.GetEnumerator() - if (e.MoveNext()) then e.Current - else invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + + if (e.MoveNext()) then + e.Current + else + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString [] - let tryHead (source : seq<_>) = + let tryHead (source: seq<_>) = checkNonNull "source" source use e = source.GetEnumerator() - if (e.MoveNext()) then Some e.Current - else None + + if (e.MoveNext()) then + Some e.Current + else + None [] let tail (source: seq<'T>) = checkNonNull "source" source - seq { use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" (SR.GetString(SR.notEnoughElements)) - while e.MoveNext() do - yield e.Current } - + + seq { + use e = source.GetEnumerator() + + if not (e.MoveNext()) then + invalidArg "source" (SR.GetString(SR.notEnoughElements)) + + while e.MoveNext() do + yield e.Current + } + [] - let last (source : seq<_>) = + let last (source: seq<_>) = checkNonNull "source" source + match Microsoft.FSharp.Primitives.Basics.Seq.tryLastV source with | ValueSome x -> x | ValueNone -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - + [] - let tryLast (source : seq<_>) = + let tryLast (source: seq<_>) = checkNonNull "source" source + match Microsoft.FSharp.Primitives.Basics.Seq.tryLastV source with | ValueSome x -> Some x | ValueNone -> None - + [] - let exactlyOne (source : seq<_>) = + let exactlyOne (source: seq<_>) = checkNonNull "source" source use e = source.GetEnumerator() + if e.MoveNext() then let v = e.Current + if e.MoveNext() then invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) else @@ -1415,43 +1693,41 @@ module Seq = invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString [] - let tryExactlyOne (source : seq<_>) = + let tryExactlyOne (source: seq<_>) = checkNonNull "source" source use e = source.GetEnumerator() + if e.MoveNext() then let v = e.Current - if e.MoveNext() then - None - else - Some v + if e.MoveNext() then None else Some v else None [] let rev source = checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray Array.Reverse array array :> seq<_>) [] - let permute indexMap (source : seq<_>) = + let permute indexMap (source: seq<_>) = checkNonNull "source" source - mkDelayedSeq (fun () -> - source |> toArray |> Array.permute indexMap :> seq<_>) + mkDelayedSeq (fun () -> source |> toArray |> Array.permute indexMap :> seq<_>) [] - let mapFold<'T,'State,'Result> (mapping: 'State -> 'T -> 'Result * 'State) state source = + let mapFold<'T, 'State, 'Result> (mapping: 'State -> 'T -> 'Result * 'State) state source = checkNonNull "source" source - let arr,state = source |> toArray |> Array.mapFold mapping state + let arr, state = source |> toArray |> Array.mapFold mapping state readonly arr, state [] - let mapFoldBack<'T,'State,'Result> (mapping: 'T -> 'State -> 'Result * 'State) source state = + let mapFoldBack<'T, 'State, 'Result> (mapping: 'T -> 'State -> 'Result * 'State) source state = checkNonNull "source" source let array = source |> toArray - let arr,state = Array.mapFoldBack mapping array state + let arr, state = Array.mapFoldBack mapping array state readonly arr, state [] @@ -1461,102 +1737,142 @@ module Seq = seq { use e = source.GetEnumerator() + if e.MoveNext() then let cached = HashSet(itemsToExclude, HashIdentity.Structural) let next = e.Current if cached.Add next then yield next + while e.MoveNext() do let next = e.Current - if cached.Add next then yield next } + if cached.Add next then yield next + } [] - let chunkBySize chunkSize (source : seq<_>) = - checkNonNull "source" source - if chunkSize <= 0 then invalidArgFmt "chunkSize" "{0}\nchunkSize = {1}" - [|SR.GetString SR.inputMustBePositive; chunkSize|] - seq { use e = source.GetEnumerator() - let nextChunk() = - let res = Array.zeroCreateUnchecked chunkSize - res.[0] <- e.Current - let mutable i = 1 - while i < chunkSize && e.MoveNext() do - res.[i] <- e.Current - i <- i + 1 - if i = chunkSize then - res - else - res |> Array.subUnchecked 0 i - while e.MoveNext() do - yield nextChunk() } + let chunkBySize chunkSize (source: seq<_>) = + checkNonNull "source" source + + if chunkSize <= 0 then + invalidArgFmt "chunkSize" "{0}\nchunkSize = {1}" [| SR.GetString SR.inputMustBePositive; chunkSize |] + + seq { + use e = source.GetEnumerator() + + let nextChunk () = + let res = Array.zeroCreateUnchecked chunkSize + res.[0] <- e.Current + let mutable i = 1 + + while i < chunkSize && e.MoveNext() do + res.[i] <- e.Current + i <- i + 1 + + if i = chunkSize then + res + else + res |> Array.subUnchecked 0 i + + while e.MoveNext() do + yield nextChunk () + } [] let splitInto count source = checkNonNull "source" source - if count <= 0 then invalidArgFmt "count" "{0}\ncount = {1}" - [|SR.GetString SR.inputMustBePositive; count|] - mkDelayedSeq (fun () -> - source |> toArray |> Array.splitInto count :> seq<_>) + + if count <= 0 then + invalidArgFmt "count" "{0}\ncount = {1}" [| SR.GetString SR.inputMustBePositive; count |] + + mkDelayedSeq (fun () -> source |> toArray |> Array.splitInto count :> seq<_>) [] let removeAt (index: int) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" + if index < 0 then + invalidArg "index" "index must be within bounds of the array" + seq { let mutable i = 0 + for item in source do - if i <> index then - yield item + if i <> index then yield item i <- i + 1 - if i <= index then invalidArg "index" "index must be within bounds of the array" + + if i <= index then + invalidArg "index" "index must be within bounds of the array" } [] let removeManyAt (index: int) (count: int) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" + if index < 0 then + invalidArg "index" "index must be within bounds of the array" + seq { let mutable i = 0 + for item in source do - if i < index || i >= index + count then + if i < index || i >= index + count then yield item + i <- i + 1 - if i <= index then invalidArg "index" "index must be within bounds of the array" + + if i <= index then + invalidArg "index" "index must be within bounds of the array" } [] let updateAt (index: int) (value: 'T) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" + if index < 0 then + invalidArg "index" "index must be within bounds of the array" + seq { let mutable i = 0 + for item in source do if i <> index then yield item - else yield value + else + yield value + i <- i + 1 - if i <= index then invalidArg "index" "index must be within bounds of the array" + + if i <= index then + invalidArg "index" "index must be within bounds of the array" } [] let insertAt (index: int) (value: 'T) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" + if index < 0 then + invalidArg "index" "index must be within bounds of the array" + seq { let mutable i = 0 + for item in source do - if i = index then - yield value + if i = index then yield value yield item i <- i + 1 + if i = index then yield value - if i < index then invalidArg "index" "index must be within bounds of the array" + + if i < index then + invalidArg "index" "index must be within bounds of the array" } [] let insertManyAt (index: int) (values: seq<'T>) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" + if index < 0 then + invalidArg "index" "index must be within bounds of the array" + seq { let mutable i = 0 + for item in source do if i = index then yield! values - yield item + yield item i <- i + 1 + if i = index then yield! values // support inserting at the end - if i < index then invalidArg "index" "index must be within bounds of the array" - } \ No newline at end of file + + if i < index then + invalidArg "index" "index must be within bounds of the array" + } diff --git a/src/FSharp.Core/seqcore.fsi b/src/FSharp.Core/seqcore.fsi index 162458d8c90..03496378232 100644 --- a/src/FSharp.Core/seqcore.fsi +++ b/src/FSharp.Core/seqcore.fsi @@ -100,8 +100,8 @@ module RuntimeHelpers = /// The input sequence. /// /// The result sequence. - val EnumerateUsing: resource: 'T -> source: ('T -> 'Collection) -> seq<'U> - when 'T :> IDisposable and 'Collection :> seq<'U> + val EnumerateUsing: + resource: 'T -> source: ('T -> 'Collection) -> seq<'U> when 'T :> IDisposable and 'Collection :> seq<'U> /// Creates an anonymous event with the given handlers. /// diff --git a/src/FSharp.Core/set.fs b/src/FSharp.Core/set.fs index e59d3052168..f04cc12433e 100644 --- a/src/FSharp.Core/set.fs +++ b/src/FSharp.Core/set.fs @@ -19,37 +19,38 @@ open Microsoft.FSharp.Collections type internal SetTree<'T>(k: 'T, h: int) = member _.Height = h member _.Key = k - new(k: 'T) = SetTree(k,1) - + new(k: 'T) = SetTree(k, 1) + [] [] [] -type internal SetTreeNode<'T>(v:'T, left:SetTree<'T>, right: SetTree<'T>, h: int) = - inherit SetTree<'T>(v,h) +type internal SetTreeNode<'T>(v: 'T, left: SetTree<'T>, right: SetTree<'T>, h: int) = + inherit SetTree<'T>(v, h) member _.Left = left member _.Right = right - + [] -module internal SetTree = - +module internal SetTree = + let empty = null - - let inline isEmpty (t:SetTree<'T>) = isNull t - let inline private asNode(value:SetTree<'T>) : SetTreeNode<'T> = + let inline isEmpty (t: SetTree<'T>) = + isNull t + + let inline private asNode (value: SetTree<'T>) : SetTreeNode<'T> = value :?> SetTreeNode<'T> - - let rec countAux (t:SetTree<'T>) acc = + + let rec countAux (t: SetTree<'T>) acc = if isEmpty t then acc + else if t.Height = 1 then + acc + 1 else - if t.Height = 1 then - acc + 1 - else - let tn = asNode t - countAux tn.Left (countAux tn.Right (acc+1)) + let tn = asNode t + countAux tn.Left (countAux tn.Right (acc + 1)) - let count s = countAux s 0 + let count s = + countAux s 0 #if TRACE_SETS_AND_MAPS let mutable traceCount = 0 @@ -63,377 +64,472 @@ module internal SetTree = let mutable totalSizeOnSetAdd = 0.0 let mutable totalSizeOnSetLookup = 0.0 - let report() = - traceCount <- traceCount + 1 - if traceCount % 10000 = 0 then - System.Console.WriteLine( + let report () = + traceCount <- traceCount + 1 + + if traceCount % 10000 = 0 then + System.Console.WriteLine( "#SetOne = {0}, #SetNode = {1}, #Add = {2}, #Remove = {3}, #Unions = {4}, #Lookups = {5}, avSetSizeOnNodeCreation = {6}, avSetSizeOnSetCreation = {7}, avSetSizeOnSetLookup = {8}", - numOnes, numNodes, numAdds, numRemoves, numUnions, numLookups, + numOnes, + numNodes, + numAdds, + numRemoves, + numUnions, + numLookups, (totalSizeOnNodeCreation / float (numNodes + numOnes)), (totalSizeOnSetAdd / float numAdds), - (totalSizeOnSetLookup / float numLookups)) + (totalSizeOnSetLookup / float numLookups) + ) - let SetTree n = - report() + let SetTree n = + report () numOnes <- numOnes + 1 totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 SetTree n - let SetTreeNode (x, l, r, h) = - report() + let SetTreeNode (x, l, r, h) = + report () numNodes <- numNodes + 1 - let n = SetTreeNode (x, l, r, h) + let n = SetTreeNode(x, l, r, h) totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (count n) n #endif - let inline height (t:SetTree<'T>) = - if isEmpty t then 0 - else t.Height + let inline height (t: SetTree<'T>) = + if isEmpty t then 0 else t.Height [] let private tolerance = 2 - let mk l k r : SetTree<'T> = - let hl = height l - let hr = height r + let mk l k r : SetTree<'T> = + let hl = height l + let hr = height r let m = if hl < hr then hr else hl + if m = 0 then // m=0 ~ isEmpty l && isEmpty r SetTree k else - SetTreeNode (k, l, r, m+1) :> SetTree<'T> + SetTreeNode(k, l, r, m + 1) :> SetTree<'T> let rebalance t1 v t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + tolerance then // right is heavier than left - let t2' = asNode(t2) - // one of the nodes must have height > height t1 + 1 - if height t2'.Left > t1h + 1 then // balance left: combination - let t2l = asNode(t2'.Left) - mk (mk t1 v t2l.Left) t2l.Key (mk t2l.Right t2'.Key t2'.Right) + let t1h = height t1 + let t2h = height t2 + + if t2h > t1h + tolerance then // right is heavier than left + let t2' = asNode (t2) + // one of the nodes must have height > height t1 + 1 + if height t2'.Left > t1h + 1 then // balance left: combination + let t2l = asNode (t2'.Left) + mk (mk t1 v t2l.Left) t2l.Key (mk t2l.Right t2'.Key t2'.Right) else // rotate left mk (mk t1 v t2'.Left) t2.Key t2'.Right + else if t1h > t2h + tolerance then // left is heavier than right + let t1' = asNode (t1) + // one of the nodes must have height > height t2 + 1 + if height t1'.Right > t2h + 1 then + // balance right: combination + let t1r = asNode (t1'.Right) + mk (mk t1'.Left t1.Key t1r.Left) t1r.Key (mk t1r.Right v t2) + else + mk t1'.Left t1'.Key (mk t1'.Right v t2) else - if t1h > t2h + tolerance then // left is heavier than right - let t1' = asNode(t1) - // one of the nodes must have height > height t2 + 1 - if height t1'.Right > t2h + 1 then - // balance right: combination - let t1r = asNode(t1'.Right) - mk (mk t1'.Left t1.Key t1r.Left) t1r.Key (mk t1r.Right v t2) - else - mk t1'.Left t1'.Key (mk t1'.Right v t2) - else mk t1 v t2 + mk t1 v t2 - let rec add (comparer: IComparer<'T>) k (t:SetTree<'T>) : SetTree<'T> = - if isEmpty t then SetTree k + let rec add (comparer: IComparer<'T>) k (t: SetTree<'T>) : SetTree<'T> = + if isEmpty t then + SetTree k else let c = comparer.Compare(k, t.Key) + if t.Height = 1 then - // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - if c < 0 then SetTreeNode (k, empty, t, 2) :> SetTree<'T> - elif c = 0 then t - else SetTreeNode (k, t, empty, 2) :> SetTree<'T> + // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated + if c < 0 then + SetTreeNode(k, empty, t, 2) :> SetTree<'T> + elif c = 0 then + t + else + SetTreeNode(k, t, empty, 2) :> SetTree<'T> else let tn = asNode t - if c < 0 then rebalance (add comparer k tn.Left) tn.Key tn.Right - elif c = 0 then t - else rebalance tn.Left tn.Key (add comparer k tn.Right) - let rec balance comparer (t1:SetTree<'T>) k (t2:SetTree<'T>) = - // Given t1 < k < t2 where t1 and t2 are "balanced", + if c < 0 then + rebalance (add comparer k tn.Left) tn.Key tn.Right + elif c = 0 then + t + else + rebalance tn.Left tn.Key (add comparer k tn.Right) + + let rec balance comparer (t1: SetTree<'T>) k (t2: SetTree<'T>) = + // Given t1 < k < t2 where t1 and t2 are "balanced", // return a balanced tree for . // Recall: balance means subtrees heights differ by at most "tolerance" - if isEmpty t1 then add comparer k t2 // drop t1 = empty - elif isEmpty t2 then add comparer k t1 // drop t2 = empty + if isEmpty t1 then + add comparer k t2 // drop t1 = empty + elif isEmpty t2 then + add comparer k t1 // drop t2 = empty + else if t1.Height = 1 then + add comparer k (add comparer t1.Key t2) else - if t1.Height = 1 then add comparer k (add comparer t1.Key t2) + let t1n = asNode t1 + + if t2.Height = 1 then + add comparer k (add comparer t2.Key t1) else - let t1n = asNode t1 - if t2.Height = 1 then add comparer k (add comparer t2.Key t1) + let t2n = asNode t2 + // Have: (t1l < k1 < t1r) < k < (t2l < k2 < t2r) + // Either (a) h1, h2 differ by at most 2 - no rebalance needed. + // (b) h1 too small, i.e. h1+2 < h2 + // (c) h2 too small, i.e. h2+2 < h1 + if t1n.Height + tolerance < t2n.Height then + // case: b, h1 too small + // push t1 into low side of t2, may increase height by 1 so rebalance + rebalance (balance comparer t1 k t2n.Left) t2n.Key t2n.Right + elif t2n.Height + tolerance < t1n.Height then + // case: c, h2 too small + // push t2 into high side of t1, may increase height by 1 so rebalance + rebalance t1n.Left t1n.Key (balance comparer t1n.Right k t2) else - let t2n = asNode t2 - // Have: (t1l < k1 < t1r) < k < (t2l < k2 < t2r) - // Either (a) h1, h2 differ by at most 2 - no rebalance needed. - // (b) h1 too small, i.e. h1+2 < h2 - // (c) h2 too small, i.e. h2+2 < h1 - if t1n.Height + tolerance < t2n.Height then - // case: b, h1 too small - // push t1 into low side of t2, may increase height by 1 so rebalance - rebalance (balance comparer t1 k t2n.Left) t2n.Key t2n.Right - elif t2n.Height + tolerance < t1n.Height then - // case: c, h2 too small - // push t2 into high side of t1, may increase height by 1 so rebalance - rebalance t1n.Left t1n.Key (balance comparer t1n.Right k t2) - else - // case: a, h1 and h2 meet balance requirement - mk t1 k t2 + // case: a, h1 and h2 meet balance requirement + mk t1 k t2 - let rec split (comparer: IComparer<'T>) pivot (t:SetTree<'T>) = + let rec split (comparer: IComparer<'T>) pivot (t: SetTree<'T>) = // Given a pivot and a set t - // Return { x in t s.t. x < pivot }, pivot in t?, { x in t s.t. x > pivot } - if isEmpty t then empty, false, empty + // Return { x in t s.t. x < pivot }, pivot in t?, { x in t s.t. x > pivot } + if isEmpty t then + empty, false, empty + else if t.Height = 1 then + let c = comparer.Compare(t.Key, pivot) + + if c < 0 then t, false, empty // singleton under pivot + elif c = 0 then empty, true, empty // singleton is pivot + else empty, false, t // singleton over pivot else - if t.Height = 1 then - let c = comparer.Compare(t.Key, pivot) - if c < 0 then t, false, empty // singleton under pivot - elif c = 0 then empty, true, empty // singleton is pivot - else empty, false, t // singleton over pivot - else - let tn = asNode t - let c = comparer.Compare(pivot, tn.Key) - if c < 0 then // pivot t1 - let t11Lo, havePivot, t11Hi = split comparer pivot tn.Left - t11Lo, havePivot, balance comparer t11Hi tn.Key tn.Right - elif c = 0 then // pivot is k1 - tn.Left, true, tn.Right - else // pivot t2 - let t12Lo, havePivot, t12Hi = split comparer pivot tn.Right - balance comparer tn.Left tn.Key t12Lo, havePivot, t12Hi - - let rec spliceOutSuccessor (t:SetTree<'T>) = - if isEmpty t then failwith "internal error: Set.spliceOutSuccessor" - else - if t.Height = 1 then t.Key, empty + let tn = asNode t + let c = comparer.Compare(pivot, tn.Key) + + if c < 0 then // pivot t1 + let t11Lo, havePivot, t11Hi = split comparer pivot tn.Left + t11Lo, havePivot, balance comparer t11Hi tn.Key tn.Right + elif c = 0 then // pivot is k1 + tn.Left, true, tn.Right + else // pivot t2 + let t12Lo, havePivot, t12Hi = split comparer pivot tn.Right + balance comparer tn.Left tn.Key t12Lo, havePivot, t12Hi + + let rec spliceOutSuccessor (t: SetTree<'T>) = + if isEmpty t then + failwith "internal error: Set.spliceOutSuccessor" + else if t.Height = 1 then + t.Key, empty + else + let tn = asNode t + + if isEmpty tn.Left then + tn.Key, tn.Right else - let tn = asNode t - if isEmpty tn.Left then tn.Key, tn.Right - else let k3, l' = spliceOutSuccessor tn.Left in k3, mk l' tn.Key tn.Right + let k3, l' = spliceOutSuccessor tn.Left in k3, mk l' tn.Key tn.Right - let rec remove (comparer: IComparer<'T>) k (t:SetTree<'T>) = - if isEmpty t then t + let rec remove (comparer: IComparer<'T>) k (t: SetTree<'T>) = + if isEmpty t then + t else let c = comparer.Compare(k, t.Key) + if t.Height = 1 then if c = 0 then empty else t else let tn = asNode t - if c < 0 then rebalance (remove comparer k tn.Left) tn.Key tn.Right + + if c < 0 then + rebalance (remove comparer k tn.Left) tn.Key tn.Right elif c = 0 then - if isEmpty tn.Left then tn.Right - elif isEmpty tn.Right then tn.Left + if isEmpty tn.Left then + tn.Right + elif isEmpty tn.Right then + tn.Left else - let sk, r' = spliceOutSuccessor tn.Right + let sk, r' = spliceOutSuccessor tn.Right mk tn.Left sk r' - else rebalance tn.Left tn.Key (remove comparer k tn.Right) + else + rebalance tn.Left tn.Key (remove comparer k tn.Right) - let rec mem (comparer: IComparer<'T>) k (t:SetTree<'T>) = - if isEmpty t then false + let rec mem (comparer: IComparer<'T>) k (t: SetTree<'T>) = + if isEmpty t then + false else - let c = comparer.Compare(k, t.Key) - if t.Height = 1 then (c = 0) + let c = comparer.Compare(k, t.Key) + + if t.Height = 1 then + (c = 0) else let tn = asNode t - if c < 0 then mem comparer k tn.Left + + if c < 0 then mem comparer k tn.Left elif c = 0 then true else mem comparer k tn.Right - let rec iter f (t:SetTree<'T>) = - if isEmpty t then () + let rec iter f (t: SetTree<'T>) = + if isEmpty t then + () + else if t.Height = 1 then + f t.Key else - if t.Height = 1 then f t.Key - else - let tn = asNode t - iter f tn.Left; f tn.Key; iter f tn.Right + let tn = asNode t + iter f tn.Left + f tn.Key + iter f tn.Right - let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) (t:SetTree<'T>) x = - if isEmpty t then x + let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (t: SetTree<'T>) x = + if isEmpty t then + x + else if t.Height = 1 then + f.Invoke(t.Key, x) else - if t.Height = 1 then f.Invoke(t.Key, x) - else - let tn = asNode t - foldBackOpt f tn.Left (f.Invoke(tn.Key, (foldBackOpt f tn.Right x))) + let tn = asNode t + foldBackOpt f tn.Left (f.Invoke(tn.Key, (foldBackOpt f tn.Right x))) - let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m x + let foldBack f m x = + foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m x - let rec foldOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) x (t:SetTree<'T>) = - if isEmpty t then x + let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) x (t: SetTree<'T>) = + if isEmpty t then + x + else if t.Height = 1 then + f.Invoke(x, t.Key) else - if t.Height = 1 then f.Invoke(x, t.Key) - else - let tn = asNode t - let x = foldOpt f x tn.Left in - let x = f.Invoke(x, tn.Key) - foldOpt f x tn.Right + let tn = asNode t + let x = foldOpt f x tn.Left in + let x = f.Invoke(x, tn.Key) + foldOpt f x tn.Right - let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) x m + let fold f x m = + foldOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) x m - let rec forall f (t:SetTree<'T>) = - if isEmpty t then true + let rec forall f (t: SetTree<'T>) = + if isEmpty t then + true + else if t.Height = 1 then + f t.Key else - if t.Height = 1 then f t.Key - else - let tn = asNode t - f tn.Key && forall f tn.Left && forall f tn.Right + let tn = asNode t + f tn.Key && forall f tn.Left && forall f tn.Right - let rec exists f (t:SetTree<'T>) = - if isEmpty t then false + let rec exists f (t: SetTree<'T>) = + if isEmpty t then + false + else if t.Height = 1 then + f t.Key else - if t.Height = 1 then f t.Key - else - let tn = asNode t - f tn.Key || exists f tn.Left || exists f tn.Right + let tn = asNode t + f tn.Key || exists f tn.Left || exists f tn.Right - let subset comparer a b = + let subset comparer a b = forall (fun x -> mem comparer x b) a - let properSubset comparer a b = - forall (fun x -> mem comparer x b) a && exists (fun x -> not (mem comparer x a)) b + let properSubset comparer a b = + forall (fun x -> mem comparer x b) a + && exists (fun x -> not (mem comparer x a)) b - let rec filterAux comparer f (t:SetTree<'T>) acc = - if isEmpty t then acc - else - if t.Height = 1 then - if f t.Key then add comparer t.Key acc else acc + let rec filterAux comparer f (t: SetTree<'T>) acc = + if isEmpty t then + acc + else if t.Height = 1 then + if f t.Key then + add comparer t.Key acc else - let tn = asNode t - let acc = if f tn.Key then add comparer tn.Key acc else acc - filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) + acc + else + let tn = asNode t + + let acc = + if f tn.Key then + add comparer tn.Key acc + else + acc - let filter comparer f s = filterAux comparer f s empty + filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) - let rec diffAux comparer (t:SetTree<'T>) acc = - if isEmpty acc then acc + let filter comparer f s = + filterAux comparer f s empty + + let rec diffAux comparer (t: SetTree<'T>) acc = + if isEmpty acc then + acc + else if isEmpty t then + acc + else if t.Height = 1 then + remove comparer t.Key acc else - if isEmpty t then acc - else - if t.Height = 1 then remove comparer t.Key acc - else - let tn = asNode t - diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) + let tn = asNode t + diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) - let diff comparer a b = diffAux comparer b a + let diff comparer a b = + diffAux comparer b a - let rec union comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = - // Perf: tried bruteForce for low heights, but nothing significant - if isEmpty t1 then t2 - elif isEmpty t2 then t1 + let rec union comparer (t1: SetTree<'T>) (t2: SetTree<'T>) = + // Perf: tried bruteForce for low heights, but nothing significant + if isEmpty t1 then + t2 + elif isEmpty t2 then + t1 + else if t1.Height = 1 then + add comparer t1.Key t2 + else if t2.Height = 1 then + add comparer t2.Key t1 else - if t1.Height = 1 then add comparer t1.Key t2 + let t1n = asNode t1 + let t2n = asNode t2 // (t1l < k < t1r) AND (t2l < k2 < t2r) + // Divide and Conquer: + // Suppose t1 is largest. + // Split t2 using pivot k1 into lo and hi. + // Union disjoint subproblems and then combine. + if t1n.Height > t2n.Height then + let lo, _, hi = split comparer t1n.Key t2 in + + balance comparer (union comparer t1n.Left lo) t1n.Key (union comparer t1n.Right hi) else - if t2.Height = 1 then add comparer t2.Key t1 - else - let t1n = asNode t1 - let t2n = asNode t2 // (t1l < k < t1r) AND (t2l < k2 < t2r) - // Divide and Conquer: - // Suppose t1 is largest. - // Split t2 using pivot k1 into lo and hi. - // Union disjoint subproblems and then combine. - if t1n.Height > t2n.Height then - let lo, _, hi = split comparer t1n.Key t2 in - balance comparer (union comparer t1n.Left lo) t1n.Key (union comparer t1n.Right hi) - else - let lo, _, hi = split comparer t2n.Key t1 in - balance comparer (union comparer t2n.Left lo) t2n.Key (union comparer t2n.Right hi) + let lo, _, hi = split comparer t2n.Key t1 in - let rec intersectionAux comparer b (t:SetTree<'T>) acc = - if isEmpty t then acc - else - if t.Height = 1 then - if mem comparer t.Key b then add comparer t.Key acc else acc + balance comparer (union comparer t2n.Left lo) t2n.Key (union comparer t2n.Right hi) + + let rec intersectionAux comparer b (t: SetTree<'T>) acc = + if isEmpty t then + acc + else if t.Height = 1 then + if mem comparer t.Key b then + add comparer t.Key acc else - let tn = asNode t - let acc = intersectionAux comparer b tn.Right acc - let acc = if mem comparer tn.Key b then add comparer tn.Key acc else acc - intersectionAux comparer b tn.Left acc + acc + else + let tn = asNode t + let acc = intersectionAux comparer b tn.Right acc - let intersection comparer a b = intersectionAux comparer b a empty + let acc = + if mem comparer tn.Key b then + add comparer tn.Key acc + else + acc + + intersectionAux comparer b tn.Left acc - let partition1 comparer f k (acc1, acc2) = if f k then (add comparer k acc1, acc2) else (acc1, add comparer k acc2) + let intersection comparer a b = + intersectionAux comparer b a empty - let rec partitionAux comparer f (t:SetTree<'T>) acc = - if isEmpty t then acc + let partition1 comparer f k (acc1, acc2) = + if f k then + (add comparer k acc1, acc2) else - if t.Height = 1 then partition1 comparer f t.Key acc - else - let tn = asNode t - let acc = partitionAux comparer f tn.Right acc - let acc = partition1 comparer f tn.Key acc - partitionAux comparer f tn.Left acc + (acc1, add comparer k acc2) + + let rec partitionAux comparer f (t: SetTree<'T>) acc = + if isEmpty t then + acc + else if t.Height = 1 then + partition1 comparer f t.Key acc + else + let tn = asNode t + let acc = partitionAux comparer f tn.Right acc + let acc = partition1 comparer f tn.Key acc + partitionAux comparer f tn.Left acc - let partition comparer f s = partitionAux comparer f s (empty, empty) + let partition comparer f s = + partitionAux comparer f s (empty, empty) - let rec minimumElementAux (t:SetTree<'T>) n = - if isEmpty t then n + let rec minimumElementAux (t: SetTree<'T>) n = + if isEmpty t then + n + else if t.Height = 1 then + t.Key else - if t.Height = 1 then t.Key - else - let tn = asNode t - minimumElementAux tn.Left tn.Key + let tn = asNode t + minimumElementAux tn.Left tn.Key - and minimumElementOpt (t:SetTree<'T>) = - if isEmpty t then None + and minimumElementOpt (t: SetTree<'T>) = + if isEmpty t then + None + else if t.Height = 1 then + Some t.Key else - if t.Height = 1 then Some t.Key - else - let tn = asNode t - Some(minimumElementAux tn.Left tn.Key) + let tn = asNode t + Some(minimumElementAux tn.Left tn.Key) - and maximumElementAux (t:SetTree<'T>) n = - if isEmpty t then n + and maximumElementAux (t: SetTree<'T>) n = + if isEmpty t then + n + else if t.Height = 1 then + t.Key else - if t.Height = 1 then t.Key - else - let tn = asNode t - maximumElementAux tn.Right tn.Key + let tn = asNode t + maximumElementAux tn.Right tn.Key - and maximumElementOpt (t:SetTree<'T>) = - if isEmpty t then None + and maximumElementOpt (t: SetTree<'T>) = + if isEmpty t then + None + else if t.Height = 1 then + Some t.Key else - if t.Height = 1 then Some t.Key - else - let tn = asNode t - Some(maximumElementAux tn.Right tn.Key) + let tn = asNode t + Some(maximumElementAux tn.Right tn.Key) - let minimumElement s = - match minimumElementOpt s with + let minimumElement s = + match minimumElementOpt s with | Some k -> k - | None -> invalidArg "s" (SR.GetString(SR.setContainsNoElements)) + | None -> invalidArg "s" (SR.GetString(SR.setContainsNoElements)) - let maximumElement s = - match maximumElementOpt s with + let maximumElement s = + match maximumElementOpt s with | Some k -> k - | None -> invalidArg "s" (SR.GetString(SR.setContainsNoElements)) + | None -> invalidArg "s" (SR.GetString(SR.setContainsNoElements)) // Imperative left-to-right iterators. [] - type SetIterator<'T> when 'T: comparison = - { mutable stack: SetTree<'T> list; // invariant: always collapseLHS result - mutable started: bool // true when MoveNext has been called + type SetIterator<'T> when 'T: comparison = + { + mutable stack: SetTree<'T> list // invariant: always collapseLHS result + mutable started: bool // true when MoveNext has been called } // collapseLHS: // a) Always returns either [] or a list starting with SetOne. // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS (stack: SetTree<'T> list) = + let rec collapseLHS (stack: SetTree<'T> list) = match stack with | [] -> [] | x :: rest -> - if isEmpty x then collapseLHS rest + if isEmpty x then + collapseLHS rest + else if x.Height = 1 then + stack else - if x.Height = 1 then stack - else - let xn = asNode x - collapseLHS (xn.Left :: SetTree xn.Key :: xn.Right :: rest) + let xn = asNode x + collapseLHS (xn.Left :: SetTree xn.Key :: xn.Right :: rest) - let mkIterator s = { stack = collapseLHS [s]; started = false } + let mkIterator s = + { + stack = collapseLHS [ s ] + started = false + } - let notStarted() = raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) + let notStarted () = + raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + let alreadyFinished () = + raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) let current i = if i.started then match i.stack with | k :: _ -> k.Key - | [] -> alreadyFinished() + | [] -> alreadyFinished () else - notStarted() + notStarted () + + let unexpectedStackForMoveNext () = + failwith "Please report error: Set iterator, unexpected stack for moveNext" + + let unexpectedstateInSetTreeCompareStacks () = + failwith "unexpected state in SetTree.compareStacks" - let unexpectedStackForMoveNext() = failwith "Please report error: Set iterator, unexpected stack for moveNext" - let unexpectedstateInSetTreeCompareStacks() = failwith "unexpected state in SetTree.compareStacks" - let rec moveNext i = if i.started then match i.stack with @@ -443,122 +539,169 @@ module internal SetTree = i.stack <- collapseLHS rest not i.stack.IsEmpty else - unexpectedStackForMoveNext() + unexpectedStackForMoveNext () else - i.started <- true; // The first call to MoveNext "starts" the enumeration. - not i.stack.IsEmpty + i.started <- true // The first call to MoveNext "starts" the enumeration. + not i.stack.IsEmpty + + let mkIEnumerator s = + let mutable i = mkIterator s - let mkIEnumerator s = - let mutable i = mkIterator s - { new IEnumerator<_> with - member _.Current = current i - interface IEnumerator with + { new IEnumerator<_> with + member _.Current = current i + interface IEnumerator with member _.Current = box (current i) - member _.MoveNext() = moveNext i - member _.Reset() = i <- mkIterator s - interface System.IDisposable with - member _.Dispose() = () } + + member _.MoveNext() = + moveNext i + + member _.Reset() = + i <- mkIterator s + interface System.IDisposable with + member _.Dispose() = + () + } /// Set comparison. Note this can be expensive. - let rec compareStacks (comparer: IComparer<'T>) (l1:SetTree<'T> list) (l2:SetTree<'T> list) : int = - let cont() = - match l1, l2 with + let rec compareStacks (comparer: IComparer<'T>) (l1: SetTree<'T> list) (l2: SetTree<'T> list) : int = + let cont () = + match l1, l2 with | (x1 :: t1), _ when not (isEmpty x1) -> if x1.Height = 1 then compareStacks comparer (empty :: SetTree x1.Key :: t1) l2 else let x1n = asNode x1 - compareStacks comparer (x1n.Left :: (SetTreeNode (x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) l2 + + compareStacks + comparer + (x1n.Left :: (SetTreeNode(x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) + l2 | _, (x2 :: t2) when not (isEmpty x2) -> if x2.Height = 1 then compareStacks comparer l1 (empty :: SetTree x2.Key :: t2) else let x2n = asNode x2 - compareStacks comparer l1 (x2n.Left :: (SetTreeNode (x2n.Key, empty, x2n.Right, 0) :> SetTree<'T> ) :: t2) - | _ -> unexpectedstateInSetTreeCompareStacks() - - match l1, l2 with - | [], [] -> 0 - | [], _ -> -1 - | _, [] -> 1 + + compareStacks + comparer + l1 + (x2n.Left :: (SetTreeNode(x2n.Key, empty, x2n.Right, 0) :> SetTree<'T>) :: t2) + | _ -> unexpectedstateInSetTreeCompareStacks () + + match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 | (x1 :: t1), (x2 :: t2) -> if isEmpty x1 then - if isEmpty x2 then compareStacks comparer t1 t2 - else cont() - elif isEmpty x2 then cont() + if isEmpty x2 then + compareStacks comparer t1 t2 + else + cont () + elif isEmpty x2 then + cont () + else if x1.Height = 1 then + if x2.Height = 1 then + let c = comparer.Compare(x1.Key, x2.Key) + + if c <> 0 then + c + else + compareStacks comparer t1 t2 + else + let x2n = asNode x2 + + if isEmpty x2n.Left then + let c = comparer.Compare(x1.Key, x2n.Key) + + if c <> 0 then + c + else + compareStacks comparer (empty :: t1) (x2n.Right :: t2) + else + cont () else - if x1.Height = 1 then + let x1n = asNode x1 + + if isEmpty x1n.Left then if x2.Height = 1 then - let c = comparer.Compare(x1.Key, x2.Key) - if c <> 0 then c else compareStacks comparer t1 t2 + let c = comparer.Compare(x1n.Key, x2.Key) + + if c <> 0 then + c + else + compareStacks comparer (x1n.Right :: t1) (empty :: t2) else let x2n = asNode x2 + if isEmpty x2n.Left then - let c = comparer.Compare(x1.Key, x2n.Key) - if c <> 0 then c else compareStacks comparer (empty :: t1) (x2n.Right :: t2) - else cont() - else - let x1n = asNode x1 - if isEmpty x1n.Left then - if x2.Height = 1 then - let c = comparer.Compare(x1n.Key, x2.Key) - if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (empty :: t2) + let c = comparer.Compare(x1n.Key, x2n.Key) + + if c <> 0 then + c + else + compareStacks comparer (x1n.Right :: t1) (x2n.Right :: t2) else - let x2n = asNode x2 - if isEmpty x2n.Left then - let c = comparer.Compare(x1n.Key, x2n.Key) - if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (x2n.Right :: t2) - else cont() - else cont() - - let compare comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = + cont () + else + cont () + + let compare comparer (t1: SetTree<'T>) (t2: SetTree<'T>) = if isEmpty t1 then - if isEmpty t2 then 0 - else -1 + if isEmpty t2 then 0 else -1 + else if isEmpty t2 then + 1 else - if isEmpty t2 then 1 - else compareStacks comparer [t1] [t2] + compareStacks comparer [ t1 ] [ t2 ] let choose s = minimumElement s - let toList (t:SetTree<'T>) = - let rec loop (t':SetTree<'T>) acc = - if isEmpty t' then acc + let toList (t: SetTree<'T>) = + let rec loop (t': SetTree<'T>) acc = + if isEmpty t' then + acc + else if t'.Height = 1 then + t'.Key :: acc else - if t'.Height = 1 then t'.Key :: acc - else - let tn = asNode t' - loop tn.Left (tn.Key :: loop tn.Right acc) + let tn = asNode t' + loop tn.Left (tn.Key :: loop tn.Right acc) + loop t [] let copyToArray s (arr: _[]) i = - let mutable j = i - iter (fun x -> arr.[j] <- x; j <- j + 1) s + let mutable j = i - let toArray s = - let n = (count s) - let res = Array.zeroCreate n + iter + (fun x -> + arr.[j] <- x + j <- j + 1) + s + + let toArray s = + let n = (count s) + let res = Array.zeroCreate n copyToArray s res 0 res - let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = - if e.MoveNext() then + let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = + if e.MoveNext() then mkFromEnumerator comparer (add comparer e.Current acc) e - else acc + else + acc let ofSeq comparer (c: IEnumerable<_>) = use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie + mkFromEnumerator comparer empty ie let ofArray comparer l = - Array.fold (fun acc k -> add comparer k acc) empty l + Array.fold (fun acc k -> add comparer k acc) empty l [] [] [>)>] [] -type Set<[]'T when 'T: comparison >(comparer:IComparer<'T>, tree: SetTree<'T>) = +type Set<[] 'T when 'T: comparison>(comparer: IComparer<'T>, tree: SetTree<'T>) = [] // NOTE: This type is logically immutable. This field is only mutated during deserialization. @@ -576,8 +719,8 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T // We use .NET generics per-instantiation static fields to avoid allocating a new object for each empty // set (it is just a lookup into a .NET table of type-instantiation-indexed static fields). - static let empty: Set<'T> = - let comparer = LanguagePrimitives.FastGenericComparer<'T> + static let empty: Set<'T> = + let comparer = LanguagePrimitives.FastGenericComparer<'T> Set<'T>(comparer, SetTree.empty) [] @@ -605,54 +748,54 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T [] static member Empty: Set<'T> = empty - member s.Add value: Set<'T> = + member s.Add value : Set<'T> = #if TRACE_SETS_AND_MAPS - SetTree.report() + SetTree.report () SetTree.numAdds <- SetTree.numAdds + 1 SetTree.totalSizeOnSetAdd <- SetTree.totalSizeOnSetAdd + float (SetTree.count s.Tree) #endif - Set<'T>(s.Comparer, SetTree.add s.Comparer value s.Tree ) + Set<'T>(s.Comparer, SetTree.add s.Comparer value s.Tree) - member s.Remove value: Set<'T> = + member s.Remove value : Set<'T> = #if TRACE_SETS_AND_MAPS - SetTree.report() + SetTree.report () SetTree.numRemoves <- SetTree.numRemoves + 1 #endif Set<'T>(s.Comparer, SetTree.remove s.Comparer value s.Tree) - member s.Count = - SetTree.count s.Tree + member s.Count = SetTree.count s.Tree - member s.Contains value = + member s.Contains value = #if TRACE_SETS_AND_MAPS - SetTree.report() + SetTree.report () SetTree.numLookups <- SetTree.numLookups + 1 SetTree.totalSizeOnSetLookup <- SetTree.totalSizeOnSetLookup + float (SetTree.count s.Tree) #endif - SetTree.mem s.Comparer value s.Tree + SetTree.mem s.Comparer value s.Tree member s.Iterate x = SetTree.iter x s.Tree - member s.Fold f z = + member s.Fold f z = let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f - SetTree.fold (fun x z -> f.Invoke(z, x)) z s.Tree + SetTree.fold (fun x z -> f.Invoke(z, x)) z s.Tree [] - member s.IsEmpty = - SetTree.isEmpty s.Tree + member s.IsEmpty = SetTree.isEmpty s.Tree - member s.Partition f : Set<'T> * Set<'T> = - if SetTree.isEmpty s.Tree then s,s + member s.Partition f : Set<'T> * Set<'T> = + if SetTree.isEmpty s.Tree then + s, s else let t1, t2 = SetTree.partition s.Comparer f s.Tree in Set(s.Comparer, t1), Set(s.Comparer, t2) - member s.Filter f : Set<'T> = - if SetTree.isEmpty s.Tree then s + member s.Filter f : Set<'T> = + if SetTree.isEmpty s.Tree then + s else Set(s.Comparer, SetTree.filter s.Comparer f s.Tree) - member s.Map f : Set<'U> = + member s.Map f : Set<'U> = let comparer = LanguagePrimitives.FastGenericComparer<'U> Set(comparer, SetTree.fold (fun acc k -> SetTree.add comparer (f k) acc) (SetTree.empty) s.Tree) @@ -662,39 +805,45 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T member s.ForAll f = SetTree.forall f s.Tree - static member (-) (set1: Set<'T>, set2: Set<'T>) = - if SetTree.isEmpty set1.Tree then set1 (* 0 - B = 0 *) + static member (-)(set1: Set<'T>, set2: Set<'T>) = + if SetTree.isEmpty set1.Tree then + set1 (* 0 - B = 0 *) + else if SetTree.isEmpty set2.Tree then + set1 (* A - 0 = A *) else - if SetTree.isEmpty set2.Tree then set1 (* A - 0 = A *) - else Set(set1.Comparer, SetTree.diff set1.Comparer set1.Tree set2.Tree) + Set(set1.Comparer, SetTree.diff set1.Comparer set1.Tree set2.Tree) - static member (+) (set1: Set<'T>, set2: Set<'T>) = + static member (+)(set1: Set<'T>, set2: Set<'T>) = #if TRACE_SETS_AND_MAPS - SetTree.report() + SetTree.report () SetTree.numUnions <- SetTree.numUnions + 1 #endif - if SetTree.isEmpty set2.Tree then set1 (* A U 0 = A *) + if SetTree.isEmpty set2.Tree then + set1 (* A U 0 = A *) + else if SetTree.isEmpty set1.Tree then + set2 (* 0 U B = B *) else - if SetTree.isEmpty set1.Tree then set2 (* 0 U B = B *) - else Set(set1.Comparer, SetTree.union set1.Comparer set1.Tree set2.Tree) + Set(set1.Comparer, SetTree.union set1.Comparer set1.Tree set2.Tree) - static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = - if SetTree.isEmpty b.Tree then b (* A INTER 0 = 0 *) + static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = + if SetTree.isEmpty b.Tree then + b (* A INTER 0 = 0 *) + else if SetTree.isEmpty a.Tree then + a (* 0 INTER B = 0 *) else - if SetTree.isEmpty a.Tree then a (* 0 INTER B = 0 *) - else Set(a.Comparer, SetTree.intersection a.Comparer a.Tree b.Tree) + Set(a.Comparer, SetTree.intersection a.Comparer a.Tree b.Tree) - static member Union(sets:seq>) : Set<'T> = + static member Union(sets: seq>) : Set<'T> = Seq.fold (fun s1 s2 -> s1 + s2) Set<'T>.Empty sets - static member Intersection(sets:seq>) : Set<'T> = + static member Intersection(sets: seq>) : Set<'T> = Seq.reduce (fun s1 s2 -> Set.Intersection(s1, s2)) sets static member Equality(a: Set<'T>, b: Set<'T>) = - (SetTree.compare a.Comparer a.Tree b.Tree = 0) + (SetTree.compare a.Comparer a.Tree b.Tree = 0) static member Compare(a: Set<'T>, b: Set<'T>) = - SetTree.compare a.Comparer a.Tree b.Tree + SetTree.compare a.Comparer a.Tree b.Tree [] member x.Choose = SetTree.choose x.Tree @@ -706,55 +855,72 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T member x.MaximumElement = SetTree.maximumElement x.Tree member x.IsSubsetOf(otherSet: Set<'T>) = - SetTree.subset x.Comparer x.Tree otherSet.Tree + SetTree.subset x.Comparer x.Tree otherSet.Tree member x.IsSupersetOf(otherSet: Set<'T>) = SetTree.subset x.Comparer otherSet.Tree x.Tree member x.IsProperSubsetOf(otherSet: Set<'T>) = - SetTree.properSubset x.Comparer x.Tree otherSet.Tree + SetTree.properSubset x.Comparer x.Tree otherSet.Tree member x.IsProperSupersetOf(otherSet: Set<'T>) = SetTree.properSubset x.Comparer otherSet.Tree x.Tree - member x.ToList () = SetTree.toList x.Tree + member x.ToList() = + SetTree.toList x.Tree - member x.ToArray () = SetTree.toArray x.Tree + member x.ToArray() = + SetTree.toArray x.Tree + + member this.ComputeHashCode() = + let combineHash x y = + (x <<< 1) + y + 631 - member this.ComputeHashCode() = - let combineHash x y = (x <<< 1) + y + 631 let mutable res = 0 + for x in this do res <- combineHash res (hash x) + res - override this.GetHashCode() = this.ComputeHashCode() + override this.GetHashCode() = + this.ComputeHashCode() + + override this.Equals that = + match that with + | :? Set<'T> as that -> + use e1 = (this :> seq<_>).GetEnumerator() + use e2 = (that :> seq<_>).GetEnumerator() - override this.Equals that = - match that with - | :? Set<'T> as that -> - use e1 = (this :> seq<_>).GetEnumerator() - use e2 = (that :> seq<_>).GetEnumerator() - let rec loop () = - let m1 = e1.MoveNext() + let rec loop () = + let m1 = e1.MoveNext() let m2 = e2.MoveNext() - (m1 = m2) && (not m1 || ((e1.Current = e2.Current) && loop())) - loop() + (m1 = m2) && (not m1 || ((e1.Current = e2.Current) && loop ())) + + loop () | _ -> false - interface System.IComparable with - member this.CompareTo(that: obj) = SetTree.compare this.Comparer this.Tree ((that :?> Set<'T>).Tree) + interface System.IComparable with + member this.CompareTo(that: obj) = + SetTree.compare this.Comparer this.Tree ((that :?> Set<'T>).Tree) - interface ICollection<'T> with - member s.Add x = ignore x; raise (new System.NotSupportedException("ReadOnlyCollection")) + interface ICollection<'T> with + member s.Add x = + ignore x + raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Clear() = raise (new System.NotSupportedException("ReadOnlyCollection")) + member s.Clear() = + raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Remove x = ignore x; raise (new System.NotSupportedException("ReadOnlyCollection")) + member s.Remove x = + ignore x + raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Contains x = SetTree.mem s.Comparer x s.Tree + member s.Contains x = + SetTree.mem s.Comparer x s.Tree - member s.CopyTo(arr, i) = SetTree.copyToArray s.Tree arr i + member s.CopyTo(arr, i) = + SetTree.copyToArray s.Tree arr i member s.IsReadOnly = true @@ -764,150 +930,205 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T member s.Count = s.Count interface IEnumerable<'T> with - member s.GetEnumerator() = SetTree.mkIEnumerator s.Tree + member s.GetEnumerator() = + SetTree.mkIEnumerator s.Tree interface IEnumerable with - override s.GetEnumerator() = (SetTree.mkIEnumerator s.Tree :> IEnumerator) + override s.GetEnumerator() = + (SetTree.mkIEnumerator s.Tree :> IEnumerator) - static member Singleton(x:'T) : Set<'T> = Set<'T>.Empty.Add x + static member Singleton(x: 'T) : Set<'T> = + Set<'T>.Empty.Add x - new (elements : seq<'T>) = + new(elements: seq<'T>) = let comparer = LanguagePrimitives.FastGenericComparer<'T> Set(comparer, SetTree.ofSeq comparer elements) - static member Create(elements : seq<'T>) = Set<'T>(elements) + static member Create(elements: seq<'T>) = + Set<'T>(elements) - static member FromArray(arr : 'T array) : Set<'T> = + static member FromArray(arr: 'T array) : Set<'T> = let comparer = LanguagePrimitives.FastGenericComparer<'T> Set(comparer, SetTree.ofArray comparer arr) - override x.ToString() = - match List.ofSeq (Seq.truncate 4 x) with + override x.ToString() = + match List.ofSeq (Seq.truncate 4 x) with | [] -> "set []" - | [h1] -> + | [ h1 ] -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 StringBuilder().Append("set [").Append(txt1).Append("]").ToString() - | [h1; h2] -> + | [ h1; h2 ] -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 let txt2 = LanguagePrimitives.anyToStringShowingNull h2 - StringBuilder().Append("set [").Append(txt1).Append("; ").Append(txt2).Append("]").ToString() - | [h1; h2; h3] -> + + StringBuilder() + .Append("set [") + .Append(txt1) + .Append("; ") + .Append(txt2) + .Append("]") + .ToString() + | [ h1; h2; h3 ] -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 let txt2 = LanguagePrimitives.anyToStringShowingNull h2 let txt3 = LanguagePrimitives.anyToStringShowingNull h3 - StringBuilder().Append("set [").Append(txt1).Append("; ").Append(txt2).Append("; ").Append(txt3).Append("]").ToString() + + StringBuilder() + .Append("set [") + .Append(txt1) + .Append("; ") + .Append(txt2) + .Append("; ") + .Append(txt3) + .Append("]") + .ToString() | h1 :: h2 :: h3 :: _ -> let txt1 = LanguagePrimitives.anyToStringShowingNull h1 let txt2 = LanguagePrimitives.anyToStringShowingNull h2 let txt3 = LanguagePrimitives.anyToStringShowingNull h3 - StringBuilder().Append("set [").Append(txt1).Append("; ").Append(txt2).Append("; ").Append(txt3).Append("; ... ]").ToString() -and - [] - SetDebugView<'T when 'T : comparison>(v: Set<'T>) = + StringBuilder() + .Append("set [") + .Append(txt1) + .Append("; ") + .Append(txt2) + .Append("; ") + .Append(txt3) + .Append("; ... ]") + .ToString() - [] - member x.Items = v |> Seq.truncate 1000 |> Seq.toArray +and [] SetDebugView<'T when 'T: comparison>(v: Set<'T>) = + + [] + member x.Items = v |> Seq.truncate 1000 |> Seq.toArray [] [] -module Set = +module Set = [] - let isEmpty (set: Set<'T>) = set.IsEmpty + let isEmpty (set: Set<'T>) = + set.IsEmpty [] - let contains element (set: Set<'T>) = set.Contains element + let contains element (set: Set<'T>) = + set.Contains element [] - let add value (set: Set<'T>) = set.Add value + let add value (set: Set<'T>) = + set.Add value [] - let singleton value = Set<'T>.Singleton value + let singleton value = + Set<'T>.Singleton value [] - let remove value (set: Set<'T>) = set.Remove value + let remove value (set: Set<'T>) = + set.Remove value [] - let union (set1: Set<'T>) (set2: Set<'T>) = set1 + set2 + let union (set1: Set<'T>) (set2: Set<'T>) = + set1 + set2 [] - let unionMany sets = Set.Union sets + let unionMany sets = + Set.Union sets [] - let intersect (set1: Set<'T>) (set2: Set<'T>) = Set<'T>.Intersection(set1, set2) + let intersect (set1: Set<'T>) (set2: Set<'T>) = + Set<'T>.Intersection (set1, set2) [] - let intersectMany sets = Set.Intersection sets + let intersectMany sets = + Set.Intersection sets [] - let iter action (set: Set<'T>) = set.Iterate action + let iter action (set: Set<'T>) = + set.Iterate action [] - let empty<'T when 'T : comparison> : Set<'T> = Set<'T>.Empty + let empty<'T when 'T: comparison> : Set<'T> = Set<'T>.Empty [] - let forall predicate (set: Set<'T>) = set.ForAll predicate + let forall predicate (set: Set<'T>) = + set.ForAll predicate [] - let exists predicate (set: Set<'T>) = set.Exists predicate + let exists predicate (set: Set<'T>) = + set.Exists predicate [] - let filter predicate (set: Set<'T>) = set.Filter predicate + let filter predicate (set: Set<'T>) = + set.Filter predicate [] - let partition predicate (set: Set<'T>) = set.Partition predicate + let partition predicate (set: Set<'T>) = + set.Partition predicate [] - let fold<'T, 'State when 'T : comparison> folder (state:'State) (set: Set<'T>) = SetTree.fold folder state set.Tree + let fold<'T, 'State when 'T: comparison> folder (state: 'State) (set: Set<'T>) = + SetTree.fold folder state set.Tree [] - let foldBack<'T, 'State when 'T : comparison> folder (set: Set<'T>) (state:'State) = SetTree.foldBack folder set.Tree state + let foldBack<'T, 'State when 'T: comparison> folder (set: Set<'T>) (state: 'State) = + SetTree.foldBack folder set.Tree state [] - let map mapping (set: Set<'T>) = set.Map mapping + let map mapping (set: Set<'T>) = + set.Map mapping [] - let count (set: Set<'T>) = set.Count + let count (set: Set<'T>) = + set.Count [] - let ofList elements = Set(List.toSeq elements) + let ofList elements = + Set(List.toSeq elements) [] - let ofArray (array: 'T array) = Set<'T>.FromArray array + let ofArray (array: 'T array) = + Set<'T>.FromArray array [] - let toList (set: Set<'T>) = set.ToList() + let toList (set: Set<'T>) = + set.ToList() [] - let toArray (set: Set<'T>) = set.ToArray() + let toArray (set: Set<'T>) = + set.ToArray() [] - let toSeq (set: Set<'T>) = (set:> seq<'T>) + let toSeq (set: Set<'T>) = + (set :> seq<'T>) [] - let ofSeq (elements: seq<_>) = Set elements + let ofSeq (elements: seq<_>) = + Set elements [] - let difference (set1: Set<'T>) (set2: Set<'T>) = set1 - set2 + let difference (set1: Set<'T>) (set2: Set<'T>) = + set1 - set2 [] - let isSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set1.Tree set2.Tree + let isSubset (set1: Set<'T>) (set2: Set<'T>) = + SetTree.subset set1.Comparer set1.Tree set2.Tree [] - let isSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set2.Tree set1.Tree + let isSuperset (set1: Set<'T>) (set2: Set<'T>) = + SetTree.subset set1.Comparer set2.Tree set1.Tree [] - let isProperSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set1.Tree set2.Tree + let isProperSubset (set1: Set<'T>) (set2: Set<'T>) = + SetTree.properSubset set1.Comparer set1.Tree set2.Tree [] - let isProperSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set2.Tree set1.Tree + let isProperSuperset (set1: Set<'T>) (set2: Set<'T>) = + SetTree.properSubset set1.Comparer set2.Tree set1.Tree [] - let minElement (set: Set<'T>) = set.MinimumElement + let minElement (set: Set<'T>) = + set.MinimumElement [] - let maxElement (set: Set<'T>) = set.MaximumElement - - - + let maxElement (set: Set<'T>) = + set.MaximumElement diff --git a/src/FSharp.Core/set.fsi b/src/FSharp.Core/set.fsi index a564360689f..45056191d24 100644 --- a/src/FSharp.Core/set.fsi +++ b/src/FSharp.Core/set.fsi @@ -471,8 +471,8 @@ module Set = /// The reverse of the set is [3; 2; 1] /// [] - val fold<'T, 'State> : folder: ('State -> 'T -> 'State) -> state: 'State -> set: Set<'T> -> 'State - when 'T: comparison + val fold<'T, 'State> : + folder: ('State -> 'T -> 'State) -> state: 'State -> set: Set<'T> -> 'State when 'T: comparison /// Applies the given accumulating function to all the elements of the set. /// @@ -492,8 +492,8 @@ module Set = /// The set is [1; 2; 3] /// [] - val foldBack<'T, 'State> : folder: ('T -> 'State -> 'State) -> set: Set<'T> -> state: 'State -> 'State - when 'T: comparison + val foldBack<'T, 'State> : + folder: ('T -> 'State -> 'State) -> set: Set<'T> -> state: 'State -> 'State when 'T: comparison /// Tests if all elements of the collection satisfy the given predicate. /// If the input function is f and the elements are i0...iN and "j0...jN" diff --git a/src/FSharp.Core/string.fs b/src/FSharp.Core/string.fs index f36e430e66c..8580c6451d2 100644 --- a/src/FSharp.Core/string.fs +++ b/src/FSharp.Core/string.fs @@ -20,13 +20,13 @@ module String = let LOH_CHAR_THRESHOLD = 40_000 [] - let length (str:string) = + let length (str: string) = if isNull str then 0 else str.Length [] - let concat sep (strings : seq) = + let concat sep (strings: seq) = - let concatArray sep (strings: string []) = + let concatArray sep (strings: string[]) = match length sep with | 0 -> String.Concat strings // following line should be used when this overload becomes part of .NET Standard (it's only in .NET Core) @@ -34,37 +34,34 @@ module String = | _ -> String.Join(sep, strings, 0, strings.Length) match strings with - | :? (string[]) as arr -> - concatArray sep arr + | :? (string[]) as arr -> concatArray sep arr - | :? (string list) as lst -> - lst - |> List.toArray - |> concatArray sep + | :? (string list) as lst -> lst |> List.toArray |> concatArray sep - | _ -> - String.Join(sep, strings) + | _ -> String.Join(sep, strings) [] - let iter (action : (char -> unit)) (str:string) = + let iter (action: (char -> unit)) (str: string) = if not (String.IsNullOrEmpty str) then for i = 0 to str.Length - 1 do - action str.[i] + action str.[i] [] - let iteri action (str:string) = + let iteri action (str: string) = if not (String.IsNullOrEmpty str) then - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (action) + for i = 0 to str.Length - 1 do - f.Invoke(i, str.[i]) + f.Invoke(i, str.[i]) [] - let map (mapping: char -> char) (str:string) = + let map (mapping: char -> char) (str: string) = if String.IsNullOrEmpty str then String.Empty else let result = str.ToCharArray() let mutable i = 0 + for c in result do result.[i] <- mapping c i <- i + 1 @@ -72,15 +69,17 @@ module String = new String(result) [] - let mapi (mapping: int -> char -> char) (str:string) = + let mapi (mapping: int -> char -> char) (str: string) = let len = length str - if len = 0 then + + if len = 0 then String.Empty else let result = str.ToCharArray() - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(mapping) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (mapping) let mutable i = 0 + while i < len do result.[i] <- f.Invoke(i, result.[i]) i <- i + 1 @@ -88,33 +87,39 @@ module String = new String(result) [] - let filter (predicate: char -> bool) (str:string) = + let filter (predicate: char -> bool) (str: string) = let len = length str - if len = 0 then + if len = 0 then String.Empty elif len > LOH_CHAR_THRESHOLD then - // By using SB here, which is twice slower than the optimized path, we prevent LOH allocations + // By using SB here, which is twice slower than the optimized path, we prevent LOH allocations // and 'stop the world' collections if the filtering results in smaller strings. // We also don't pre-allocate SB here, to allow for less mem pressure when filter result is small. let res = StringBuilder() - str |> iter (fun c -> if predicate c then res.Append c |> ignore) + + str + |> iter (fun c -> + if predicate c then + res.Append c |> ignore) + res.ToString() else // Must do it this way, since array.fs is not yet in scope, but this is safe let target = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len let mutable i = 0 + for c in str do - if predicate c then + if predicate c then target.[i] <- c i <- i + 1 String(target, 0, i) [] - let collect (mapping: char -> string) (str:string) = + let collect (mapping: char -> string) (str: string) = if String.IsNullOrEmpty str then String.Empty else @@ -123,19 +128,25 @@ module String = res.ToString() [] - let init (count:int) (initializer: int-> string) = - if count < 0 then invalidArgInputMustBeNonNegative "count" count + let init (count: int) (initializer: int -> string) = + if count < 0 then + invalidArgInputMustBeNonNegative "count" count + let res = StringBuilder count - for i = 0 to count - 1 do - res.Append(initializer i) |> ignore + + for i = 0 to count - 1 do + res.Append(initializer i) |> ignore + res.ToString() [] - let replicate (count:int) (str:string) = - if count < 0 then invalidArgInputMustBeNonNegative "count" count + let replicate (count: int) (str: string) = + if count < 0 then + invalidArgInputMustBeNonNegative "count" count let len = length str - if len = 0 || count = 0 then + + if len = 0 || count = 0 then String.Empty elif len = 1 then @@ -150,14 +161,17 @@ module String = else // Using the primitive, because array.fs is not yet in scope. It's safe: both len and count are positive. - let target = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len * count) + let target = + Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len * count) + let source = str.ToCharArray() // O(log(n)) performance loop: - // Copy first string, then keep copying what we already copied + // Copy first string, then keep copying what we already copied // (i.e., doubling it) until we reach or pass the halfway point Array.Copy(source, 0, target, 0, len) let mutable i = len + while i * 2 < target.Length do Array.Copy(target, 0, target, i, i) i <- i * 2 @@ -167,17 +181,21 @@ module String = new String(target) [] - let forall predicate (str:string) = + let forall predicate (str: string) = if String.IsNullOrEmpty str then true else - let rec check i = (i >= str.Length) || (predicate str.[i] && check (i+1)) + let rec check i = + (i >= str.Length) || (predicate str.[i] && check (i + 1)) + check 0 [] - let exists predicate (str:string) = + let exists predicate (str: string) = if String.IsNullOrEmpty str then false else - let rec check i = (i < str.Length) && (predicate str.[i] || check (i+1)) - check 0 + let rec check i = + (i < str.Length) && (predicate str.[i] || check (i + 1)) + + check 0 diff --git a/src/FSharp.Core/tasks.fs b/src/FSharp.Core/tasks.fs index 4ec83a25be9..a4a0e22b575 100644 --- a/src/FSharp.Core/tasks.fs +++ b/src/FSharp.Core/tasks.fs @@ -30,10 +30,10 @@ open Microsoft.FSharp.Collections type TaskStateMachineData<'T> = [] - val mutable Result : 'T + val mutable Result: 'T [] - val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> + val mutable MethodBuilder: AsyncTaskMethodBuilder<'T> and TaskStateMachine<'TOverall> = ResumableStateMachine> and TaskResumptionFunc<'TOverall> = ResumptionFunc> @@ -42,136 +42,177 @@ and TaskCode<'TOverall, 'T> = ResumableCode, 'T> type TaskBuilderBase() = - member inline _.Delay(generator : unit -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = - TaskCode<'TOverall, 'T>(fun sm -> (generator()).Invoke(&sm)) + member inline _.Delay(generator: unit -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + TaskCode<'TOverall, 'T>(fun sm -> (generator ()).Invoke(&sm)) /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. [] - member inline _.Zero() : TaskCode<'TOverall, unit> = ResumableCode.Zero() + member inline _.Zero() : TaskCode<'TOverall, unit> = + ResumableCode.Zero() - member inline _.Return (value: 'T) : TaskCode<'T, 'T> = - TaskCode<'T, _>(fun sm -> + member inline _.Return(value: 'T) : TaskCode<'T, 'T> = + TaskCode<'T, _>(fun sm -> sm.Data.Result <- value true) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - member inline _.Combine(task1: TaskCode<'TOverall, unit>, task2: TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + member inline _.Combine + ( + task1: TaskCode<'TOverall, unit>, + task2: TaskCode<'TOverall, 'T> + ) : TaskCode<'TOverall, 'T> = ResumableCode.Combine(task1, task2) /// Builds a step that executes the body while the condition predicate is true. - member inline _.While ([] condition : unit -> bool, body : TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = + member inline _.While + ( + [] condition: unit -> bool, + body: TaskCode<'TOverall, unit> + ) : TaskCode<'TOverall, unit> = ResumableCode.While(condition, body) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - member inline _.TryWith (body: TaskCode<'TOverall, 'T>, catch: exn -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + member inline _.TryWith + ( + body: TaskCode<'TOverall, 'T>, + catch: exn -> TaskCode<'TOverall, 'T> + ) : TaskCode<'TOverall, 'T> = ResumableCode.TryWith(body, catch) /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - member inline _.TryFinally (body: TaskCode<'TOverall, 'T>, [] compensation : unit -> unit) : TaskCode<'TOverall, 'T> = - ResumableCode.TryFinally(body, ResumableCode<_,_>(fun _sm -> compensation(); true)) - - member inline _.For (sequence : seq<'T>, body : 'T -> TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = + member inline _.TryFinally + ( + body: TaskCode<'TOverall, 'T>, + [] compensation: unit -> unit + ) : TaskCode<'TOverall, 'T> = + ResumableCode.TryFinally( + body, + ResumableCode<_, _>(fun _sm -> + compensation () + true) + ) + + member inline _.For(sequence: seq<'T>, body: 'T -> TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = ResumableCode.For(sequence, body) #if NETSTANDARD2_1 - member inline internal this.TryFinallyAsync(body: TaskCode<'TOverall, 'T>, compensation : unit -> ValueTask) : TaskCode<'TOverall, 'T> = - ResumableCode.TryFinallyAsync(body, ResumableCode<_,_>(fun sm -> - if __useResumableCode then - let mutable __stack_condition_fin = true - let __stack_vtask = compensation() - if not __stack_vtask.IsCompleted then - let mutable awaiter = __stack_vtask.GetAwaiter() - let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) - __stack_condition_fin <- __stack_yield_fin - - if not __stack_condition_fin then - sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) - - __stack_condition_fin - else - let vtask = compensation() - let mutable awaiter = vtask.GetAwaiter() + member inline internal this.TryFinallyAsync + ( + body: TaskCode<'TOverall, 'T>, + compensation: unit -> ValueTask + ) : TaskCode<'TOverall, 'T> = + ResumableCode.TryFinallyAsync( + body, + ResumableCode<_, _>(fun sm -> + if __useResumableCode then + let mutable __stack_condition_fin = true + let __stack_vtask = compensation () + + if not __stack_vtask.IsCompleted then + let mutable awaiter = __stack_vtask.GetAwaiter() + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_condition_fin <- __stack_yield_fin - let cont = - TaskResumptionFunc<'TOverall>( fun sm -> - awaiter.GetResult() |> ignore - true) + if not __stack_condition_fin then + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) - // shortcut to continue immediately - if awaiter.IsCompleted then - true + __stack_condition_fin else - sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) - sm.ResumptionDynamicInfo.ResumptionFunc <- cont - false - )) + let vtask = compensation () + let mutable awaiter = vtask.GetAwaiter() + + let cont = + TaskResumptionFunc<'TOverall>(fun sm -> + awaiter.GetResult() |> ignore + true) - member inline this.Using<'Resource, 'TOverall, 'T when 'Resource :> IAsyncDisposable> (resource: 'Resource, body: 'Resource -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + // shortcut to continue immediately + if awaiter.IsCompleted then + true + else + sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) + sm.ResumptionDynamicInfo.ResumptionFunc <- cont + false) + ) + + member inline this.Using<'Resource, 'TOverall, 'T when 'Resource :> IAsyncDisposable> + ( + resource: 'Resource, + body: 'Resource -> TaskCode<'TOverall, 'T> + ) : TaskCode<'TOverall, 'T> = this.TryFinallyAsync( (fun sm -> (body resource).Invoke(&sm)), - (fun () -> - if not (isNull (box resource)) then + (fun () -> + if not (isNull (box resource)) then resource.DisposeAsync() else - ValueTask())) + ValueTask()) + ) #endif - type TaskBuilder() = inherit TaskBuilderBase() // This is the dynamic implementation - this is not used - // for statically compiled tasks. An executor (resumptionFuncExecutor) is + // for statically compiled tasks. An executor (resumptionFuncExecutor) is // registered with the state machine, plus the initial resumption. // The executor stays constant throughout the execution, it wraps each step // of the execution in a try/with. The resumption is changed at each step // to represent the continuation of the computation. - static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = + static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = let mutable sm = TaskStateMachine<'T>() let initialResumptionFunc = TaskResumptionFunc<'T>(fun sm -> code.Invoke(&sm)) - let resumptionInfo = - { new TaskResumptionDynamicInfo<'T>(initialResumptionFunc) with - member info.MoveNext(sm) = + + let resumptionInfo = + { new TaskResumptionDynamicInfo<'T>(initialResumptionFunc) with + member info.MoveNext(sm) = let mutable savedExn = null + try sm.ResumptionDynamicInfo.ResumptionData <- null - let step = info.ResumptionFunc.Invoke(&sm) - if step then + let step = info.ResumptionFunc.Invoke(&sm) + + if step then sm.Data.MethodBuilder.SetResult(sm.Data.Result) else - let mutable awaiter = sm.ResumptionDynamicInfo.ResumptionData :?> ICriticalNotifyCompletion + let mutable awaiter = + sm.ResumptionDynamicInfo.ResumptionData :?> ICriticalNotifyCompletion + assert not (isNull awaiter) sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) with exn -> savedExn <- exn // Run SetException outside the stack unwind, see https://github.com/dotnet/roslyn/issues/26567 - match savedExn with + match savedExn with | null -> () | exn -> sm.Data.MethodBuilder.SetException exn member _.SetStateMachine(sm, state) = sm.Data.MethodBuilder.SetStateMachine(state) - } + } + sm.ResumptionDynamicInfo <- resumptionInfo - sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create () sm.Data.MethodBuilder.Start(&sm) sm.Data.MethodBuilder.Task - member inline _.Run(code : TaskCode<'T, 'T>) : Task<'T> = - if __useResumableCode then + member inline _.Run(code: TaskCode<'T, 'T>) : Task<'T> = + if __useResumableCode then __stateMachine, Task<'T>> - (MoveNextMethodImpl<_>(fun sm -> + (MoveNextMethodImpl<_>(fun sm -> //-- RESUMABLE CODE START - __resumeAt sm.ResumptionPoint - let mutable __stack_exn : Exception = null + __resumeAt sm.ResumptionPoint + let mutable __stack_exn: Exception = null + try let __stack_code_fin = code.Invoke(&sm) + if __stack_code_fin then sm.Data.MethodBuilder.SetResult(sm.Data.Result) with exn -> @@ -180,11 +221,11 @@ type TaskBuilder() = match __stack_exn with | null -> () | exn -> sm.Data.MethodBuilder.SetException exn - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END )) (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine(state))) - (AfterCode<_,_>(fun sm -> - sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + (AfterCode<_, _>(fun sm -> + sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create () sm.Data.MethodBuilder.Start(&sm) sm.Data.MethodBuilder.Task)) else @@ -194,53 +235,62 @@ type BackgroundTaskBuilder() = inherit TaskBuilderBase() - static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = + static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = // backgroundTask { .. } escapes to a background thread where necessary // See spec of ConfigureAwait(false) at https://devblogs.microsoft.com/dotnet/configureawait-faq/ - if isNull SynchronizationContext.Current && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) then + if + isNull SynchronizationContext.Current + && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) + then TaskBuilder.RunDynamic(code) else Task.Run<'T>(fun () -> TaskBuilder.RunDynamic(code)) //// Same as TaskBuilder.Run except the start is inside Task.Run if necessary - member inline _.Run(code : TaskCode<'T, 'T>) : Task<'T> = - if __useResumableCode then + member inline _.Run(code: TaskCode<'T, 'T>) : Task<'T> = + if __useResumableCode then __stateMachine, Task<'T>> - (MoveNextMethodImpl<_>(fun sm -> + (MoveNextMethodImpl<_>(fun sm -> //-- RESUMABLE CODE START - __resumeAt sm.ResumptionPoint + __resumeAt sm.ResumptionPoint + try let __stack_code_fin = code.Invoke(&sm) + if __stack_code_fin then sm.Data.MethodBuilder.SetResult(sm.Data.Result) with exn -> sm.Data.MethodBuilder.SetException exn - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END )) (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine(state))) - (AfterCode<_,Task<'T>>(fun sm -> + (AfterCode<_, Task<'T>>(fun sm -> // backgroundTask { .. } escapes to a background thread where necessary // See spec of ConfigureAwait(false) at https://devblogs.microsoft.com/dotnet/configureawait-faq/ - if isNull SynchronizationContext.Current && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) then - sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + if + isNull SynchronizationContext.Current + && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) + then + sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create () sm.Data.MethodBuilder.Start(&sm) sm.Data.MethodBuilder.Task else let sm = sm // copy contents of state machine so we can capture it - Task.Run<'T>(fun () -> + + Task.Run<'T>(fun () -> let mutable sm = sm // host local mutable copy of contents of state machine on this thread pool thread - sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create () sm.Data.MethodBuilder.Start(&sm) sm.Data.MethodBuilder.Task))) - else + else BackgroundTaskBuilder.RunDynamic(code) -module TaskBuilder = +module TaskBuilder = let task = TaskBuilder() let backgroundTask = BackgroundTaskBuilder() -namespace Microsoft.FSharp.Control.TaskBuilderExtensions +namespace Microsoft.FSharp.Control.TaskBuilderExtensions open Microsoft.FSharp.Control open System @@ -251,112 +301,141 @@ open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators -module LowPriority = +module LowPriority = // Low priority extensions type TaskBuilderBase with [] - static member inline BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall - when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'TResult1)> - (sm: byref<_>, task: ^TaskLike, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : bool = - - let mutable awaiter = (^TaskLike: (member GetAwaiter : unit -> ^Awaiter)(task)) - - let cont = - (TaskResumptionFunc<'TOverall>( fun sm -> - let result = (^Awaiter : (member GetResult : unit -> 'TResult1)(awaiter)) - (continuation result).Invoke(&sm))) - - // shortcut to continue immediately - if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then - cont.Invoke(&sm) - else - sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) - sm.ResumptionDynamicInfo.ResumptionFunc <- cont - false + static member inline BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter, 'TOverall + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'TResult1)> + ( + sm: byref<_>, + task: ^TaskLike, + continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>) + ) : bool = + + let mutable awaiter = (^TaskLike: (member GetAwaiter: unit -> ^Awaiter) (task)) + + let cont = + (TaskResumptionFunc<'TOverall>(fun sm -> + let result = (^Awaiter: (member GetResult: unit -> 'TResult1) (awaiter)) + (continuation result).Invoke(&sm))) + + // shortcut to continue immediately + if (^Awaiter: (member get_IsCompleted: unit -> bool) (awaiter)) then + cont.Invoke(&sm) + else + sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) + sm.ResumptionDynamicInfo.ResumptionFunc <- cont + false [] - member inline _.Bind< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall - when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'TResult1)> - (task: ^TaskLike, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = - - TaskCode<'TOverall, _>(fun sm -> - if __useResumableCode then + member inline _.Bind< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter, 'TOverall + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'TResult1)> + ( + task: ^TaskLike, + continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>) + ) : TaskCode<'TOverall, 'TResult2> = + + TaskCode<'TOverall, _>(fun sm -> + if __useResumableCode then //-- RESUMABLE CODE START // Get an awaiter from the awaitable - let mutable awaiter = (^TaskLike: (member GetAwaiter : unit -> ^Awaiter)(task)) + let mutable awaiter = (^TaskLike: (member GetAwaiter: unit -> ^Awaiter) (task)) let mutable __stack_fin = true - if not (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then + + if not (^Awaiter: (member get_IsCompleted: unit -> bool) (awaiter)) then // This will yield with __stack_yield_fin = false // This will resume with __stack_yield_fin = true let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) __stack_fin <- __stack_yield_fin - - if __stack_fin then - let result = (^Awaiter : (member GetResult : unit -> 'TResult1)(awaiter)) + + if __stack_fin then + let result = (^Awaiter: (member GetResult: unit -> 'TResult1) (awaiter)) (continuation result).Invoke(&sm) else sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) false else - TaskBuilderBase.BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall>(&sm, task, continuation) - //-- RESUMABLE CODE END + TaskBuilderBase.BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter, 'TOverall>( + &sm, + task, + continuation + ) + //-- RESUMABLE CODE END ) [] member inline this.ReturnFrom< ^TaskLike, ^Awaiter, 'T - when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'T)> - (task: ^TaskLike) : TaskCode< 'T, 'T> = + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T)> + (task: ^TaskLike) + : TaskCode<'T, 'T> = this.Bind(task, (fun v -> this.Return v)) - member inline _.Using<'Resource, 'TOverall, 'T when 'Resource :> IDisposable> (resource: 'Resource, body: 'Resource -> TaskCode<'TOverall, 'T>) = + member inline _.Using<'Resource, 'TOverall, 'T when 'Resource :> IDisposable> + ( + resource: 'Resource, + body: 'Resource -> TaskCode<'TOverall, 'T> + ) = ResumableCode.Using(resource, body) -module HighPriority = +module HighPriority = // High priority extensions type TaskBuilderBase with - static member BindDynamic (sm: byref<_>, task: Task<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : bool = + + static member BindDynamic + ( + sm: byref<_>, + task: Task<'TResult1>, + continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>) + ) : bool = let mutable awaiter = task.GetAwaiter() - let cont = - (TaskResumptionFunc<'TOverall>(fun sm -> + let cont = + (TaskResumptionFunc<'TOverall>(fun sm -> let result = awaiter.GetResult() (continuation result).Invoke(&sm))) // shortcut to continue immediately - if awaiter.IsCompleted then + if awaiter.IsCompleted then cont.Invoke(&sm) else sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) sm.ResumptionDynamicInfo.ResumptionFunc <- cont false - member inline _.Bind (task: Task<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = + member inline _.Bind + ( + task: Task<'TResult1>, + continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>) + ) : TaskCode<'TOverall, 'TResult2> = - TaskCode<'TOverall, _>(fun sm -> - if __useResumableCode then + TaskCode<'TOverall, _>(fun sm -> + if __useResumableCode then //-- RESUMABLE CODE START // Get an awaiter from the task let mutable awaiter = task.GetAwaiter() let mutable __stack_fin = true + if not awaiter.IsCompleted then // This will yield with __stack_yield_fin = false // This will resume with __stack_yield_fin = true let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) __stack_fin <- __stack_yield_fin - if __stack_fin then + + if __stack_fin then let result = awaiter.GetResult() (continuation result).Invoke(&sm) else @@ -364,21 +443,26 @@ module HighPriority = false else TaskBuilderBase.BindDynamic(&sm, task, continuation) - //-- RESUMABLE CODE END + //-- RESUMABLE CODE END ) - member inline this.ReturnFrom (task: Task<'T>) : TaskCode<'T, 'T> = + member inline this.ReturnFrom(task: Task<'T>) : TaskCode<'T, 'T> = this.Bind(task, (fun v -> this.Return v)) -module MediumPriority = +module MediumPriority = open HighPriority // Medium priority extensions type TaskBuilderBase with - member inline this.Bind (computation: Async<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = - this.Bind (Async.StartAsTask computation, continuation) - member inline this.ReturnFrom (computation: Async<'T>) : TaskCode<'T, 'T> = - this.ReturnFrom (Async.StartAsTask computation) + member inline this.Bind + ( + computation: Async<'TResult1>, + continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>) + ) : TaskCode<'TOverall, 'TResult2> = + this.Bind(Async.StartAsTask computation, continuation) + + member inline this.ReturnFrom(computation: Async<'T>) : TaskCode<'T, 'T> = + this.ReturnFrom(Async.StartAsTask computation) #endif diff --git a/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.ProjectFile.fs b/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.ProjectFile.fs index e0d6660b99b..24ad0c02f38 100644 --- a/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.ProjectFile.fs +++ b/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.ProjectFile.fs @@ -88,8 +88,8 @@ module internal ProjectFile = .ReadAllText(resolutionsFile) .Split([| '\r'; '\n' |], StringSplitOptions.None) |> Array.filter (fun line -> not (String.IsNullOrEmpty(line))) - with - | _ -> [||] + with _ -> + [||] [| for line in lines do diff --git a/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Utilities.fs b/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Utilities.fs index 1e0aeebcb7b..faa0c126948 100644 --- a/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Utilities.fs +++ b/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Utilities.fs @@ -35,10 +35,7 @@ module internal Utilities = let pos = option.IndexOf('=') let stringAsOpt text = - if String.IsNullOrEmpty(text) then - None - else - Some text + if String.IsNullOrEmpty(text) then None else Some text let nameOpt = if pos <= 0 then @@ -48,12 +45,9 @@ module internal Utilities = let valueOpt = let valueText = - if pos < 0 then - option - else if pos < option.Length then - option.Substring(pos + 1) - else - "" + if pos < 0 then option + else if pos < option.Length then option.Substring(pos + 1) + else "" stringAsOpt (valueText.Trim(trimChars)) @@ -210,6 +204,5 @@ module internal Utilities = // So strip off the flags let pos = source.IndexOf(" ") - if pos >= 0 then - yield ("i", source.Substring(pos).Trim()) + if pos >= 0 then yield ("i", source.Substring(pos).Trim()) } diff --git a/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.fs b/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.fs index 794aa591874..e5f8cd95704 100644 --- a/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.fs +++ b/src/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.fs @@ -267,8 +267,8 @@ type FSharpDependencyManager(outputDirectory: string option) = Directory.CreateDirectory(directory) |> ignore directory - with - | _ -> directory + with _ -> + directory let deleteScripts () = try @@ -279,16 +279,16 @@ type FSharpDependencyManager(outputDirectory: string option) = #else () #endif - with - | _ -> () + with _ -> + () let emitFile fileName (body: string) = try // Create a file to write to use sw = File.CreateText(fileName) sw.WriteLine(body) - with - | _ -> () + with _ -> + () let prepareDependencyResolutionFiles ( diff --git a/src/fsc/fscmain.fs b/src/fsc/fscmain.fs index 334f22c36e9..e29f07e8b20 100644 --- a/src/fsc/fscmain.fs +++ b/src/fsc/fscmain.fs @@ -81,8 +81,8 @@ let main (argv) = member _.Exit(n) = try exit n - with - | _ -> () + with _ -> + () failwithf "%s" (FSComp.SR.elSysEnvExitDidntExit ()) } @@ -116,8 +116,7 @@ let main (argv) = 0 - with - | e -> + with e -> // Last-chance error recovery (note, with a poor error range) errorRecovery e Range.range0 1 diff --git a/src/fsi/console.fs b/src/fsi/console.fs index cd84b705b4a..05f242990b2 100644 --- a/src/fsi/console.fs +++ b/src/fsi/console.fs @@ -76,8 +76,7 @@ module internal Utils = let guard (f) = try f () - with - | e -> + with e -> warning ( Failure( sprintf @@ -197,8 +196,8 @@ type internal ReadLineConsole() = |> Seq.iter (fun option -> optionsCache.Add(option)) optionsCache.Root <- root - with - | _ -> optionsCache.Clear() + with _ -> + optionsCache.Clear() optionsCache, true else @@ -210,10 +209,7 @@ type internal ReadLineConsole() = | _ -> "^?" member x.GetCharacterSize(c) = - if Char.IsControl(c) then - x.MapCharacter(c).Length - else - 1 + if Char.IsControl(c) then x.MapCharacter(c).Length else 1 static member TabSize = 4 @@ -224,12 +220,7 @@ type internal ReadLineConsole() = if currLeft < x.Inset then if currLeft = 0 then - Console.Write( - if prompt then - x.Prompt2 - else - String(' ', x.Inset) - ) + Console.Write(if prompt then x.Prompt2 else String(' ', x.Inset)) Utils.guard (fun () -> Console.CursorTop <- min Console.CursorTop (Console.BufferHeight - 1) @@ -287,8 +278,7 @@ type internal ReadLineConsole() = let mutable position = -1 for i = 0 to input.Length - 1 do - if (i = curr) then - position <- output.Length + if (i = curr) then position <- output.Length let c = input.Chars(i) @@ -297,8 +287,7 @@ type internal ReadLineConsole() = else output.Append(c) |> ignore - if (curr = input.Length) then - position <- output.Length + if (curr = input.Length) then position <- output.Length // render the current text, computing a new value for "rendered" let old_rendered = rendered @@ -377,11 +366,7 @@ type internal ReadLineConsole() = optionsCache <- opts if (opts.Count > 0) then - let part = - if shift then - opts.Previous() - else - opts.Next() + let part = if shift then opts.Previous() else opts.Next() setInput (opts.Root + part) else if (prefix) then @@ -417,11 +402,7 @@ type internal ReadLineConsole() = // REVIEW: is this F6 rewrite required? 0x1A looks like Ctrl-Z. // REVIEW: the Ctrl-Z code is not recognised as EOF by the lexer. // REVIEW: looks like a relic of the port of readline, which is currently removable. - let c = - if (key.Key = ConsoleKey.F6) then - '\x1A' - else - key.KeyChar + let c = if (key.Key = ConsoleKey.F6) then '\x1A' else key.KeyChar insertChar (c) @@ -438,8 +419,7 @@ type internal ReadLineConsole() = if (line = "\x1A") then null else - if (line.Length > 0) then - history.AddLast(line) + if (line.Length > 0) then history.AddLast(line) line diff --git a/src/fsi/fsimain.fs b/src/fsi/fsimain.fs index 9df8f0cead4..b94a152c171 100644 --- a/src/fsi/fsimain.fs +++ b/src/fsi/fsimain.fs @@ -139,8 +139,7 @@ let internal TrySetUnhandledExceptionMode () = try Application.SetUnhandledExceptionMode(UnhandledExceptionMode.CatchException) - with - | _ -> + with _ -> decr i () @@ -155,8 +154,7 @@ let StartServer (fsiSession: FsiEvaluationSession) (fsiServerName) = //printf "FSI-SERVER: received CTRL-C request...\n" try fsiSession.Interrupt() - with - | _ -> + with _ -> // Final sanity check! - catch all exns - but not expected assert false () @@ -200,8 +198,7 @@ let evaluateSession (argv: string[]) = let _ = Console.ForegroundColor let _ = Console.CursorLeft <- Console.CursorLeft true - with - | _ -> + with _ -> //if progress then fprintfn outWriter "probe failed, we have no console..." false else @@ -248,8 +245,7 @@ let evaluateSession (argv: string[]) = lazy try Some(WinFormsEventLoop()) - with - | e -> + with e -> printfn "Your system doesn't seem to support WinForms correctly. You will" printfn "need to set fsi.EventLoop use GUI windows from F# Interactive." printfn "You can set different event loops for MonoMac, Gtk#, WinForms and other" @@ -282,11 +278,7 @@ let evaluateSession (argv: string[]) = member _.EventLoopRun() = #if !FX_NO_WINFORMS - match (if fsiSession.IsGui then - fsiWinFormsLoop.Value - else - None) - with + match (if fsiSession.IsGui then fsiWinFormsLoop.Value else None) with | Some l -> (l :> IEventLoop).Run() | _ -> #endif @@ -294,11 +286,7 @@ let evaluateSession (argv: string[]) = member _.EventLoopInvoke(f) = #if !FX_NO_WINFORMS - match (if fsiSession.IsGui then - fsiWinFormsLoop.Value - else - None) - with + match (if fsiSession.IsGui then fsiWinFormsLoop.Value else None) with | Some l -> (l :> IEventLoop).Invoke(f) | _ -> #endif @@ -306,11 +294,7 @@ let evaluateSession (argv: string[]) = member _.EventLoopScheduleRestart() = #if !FX_NO_WINFORMS - match (if fsiSession.IsGui then - fsiWinFormsLoop.Value - else - None) - with + match (if fsiSession.IsGui then fsiWinFormsLoop.Value else None) with | Some l -> (l :> IEventLoop).ScheduleRestart() | _ -> #endif @@ -341,8 +325,8 @@ let evaluateSession (argv: string[]) = if fsiSession.IsGui then try Application.EnableVisualStyles() - with - | _ -> () + with _ -> + () // Route GUI application exceptions to the exception handlers Application.add_ThreadException ( @@ -352,14 +336,14 @@ let evaluateSession (argv: string[]) = let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null - with - | e -> false + with e -> + false if not runningOnMono then try TrySetUnhandledExceptionMode() - with - | _ -> () + with _ -> + () fsiWinFormsLoop.Value |> Option.iter (fun l -> l.LCID <- fsiSession.LCID) #endif @@ -400,8 +384,8 @@ let MainMain argv = member _.Dispose() = try Console.SetOut(savedOut) - with - | _ -> () + with _ -> + () } #if !FX_NO_APP_DOMAINS