From 05b560d09c611306d91a26cbacd45a1504827e14 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 30 May 2022 15:44:17 +0100 Subject: [PATCH] Format most of FSharp.Core (#13150) * modify fantomasignore * fix setting * no single line functions in FSHarp.Core * update fantomas * apply formatting --- .fantomasignore | 18 +- src/FSharp.Core/.editorconfig | 2 + src/FSharp.Core/MutableTuple.fs | 160 +- src/FSharp.Core/Nullable.fs | 329 ++- src/FSharp.Core/QueryExtensions.fs | 348 +-- src/FSharp.Core/array.fs | 1676 +++++++++----- src/FSharp.Core/async.fs | 1589 +++++++------ src/FSharp.Core/collections.fs | 67 +- src/FSharp.Core/event.fs | 195 +- src/FSharp.Core/eventmodule.fs | 87 +- src/FSharp.Core/fslib-extra-pervasives.fs | 467 ++-- src/FSharp.Core/list.fs | 578 +++-- src/FSharp.Core/mailbox.fs | 246 +- src/FSharp.Core/map.fs | 1159 ++++++---- src/FSharp.Core/math/z.fs | 114 +- src/FSharp.Core/observable.fs | 276 ++- src/FSharp.Core/option.fs | 48 +- src/FSharp.Core/quotations.fs | 2466 +++++++++++++-------- src/FSharp.Core/reflect.fs | 1085 +++++---- src/FSharp.Core/result.fs | 15 +- src/FSharp.Core/resumable.fs | 225 +- src/FSharp.Core/seq.fs | 1189 ++++++---- src/FSharp.Core/set.fs | 1115 ++++++---- src/FSharp.Core/string.fs | 98 +- src/FSharp.Core/tasks.fs | 335 +-- 25 files changed, 8619 insertions(+), 5268 deletions(-) create mode 100644 src/FSharp.Core/.editorconfig diff --git a/.fantomasignore b/.fantomasignore index 1f4485485..2fa5a7741 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -13,7 +13,6 @@ artifacts/ # Explicitly unformatted implementation files -src/FSharp.Core/**/*.fs src/Compiler/Checking/**/*.fs src/Compiler/CodeGen/**/*.fs src/Compiler/DependencyManager/**/*.fs @@ -28,6 +27,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/FSharp.Core/.editorconfig b/src/FSharp.Core/.editorconfig new file mode 100644 index 000000000..28218c4a7 --- /dev/null +++ b/src/FSharp.Core/.editorconfig @@ -0,0 +1,2 @@ +[*.fs] +fsharp_max_function_binding_width=1 diff --git a/src/FSharp.Core/MutableTuple.fs b/src/FSharp.Core/MutableTuple.fs index 79e7d5c73..a9292f1c4 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 02d58b2a8..354ce7bca 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 d7aead481..c2e86390c 100644 --- a/src/FSharp.Core/QueryExtensions.fs +++ b/src/FSharp.Core/QueryExtensions.fs @@ -17,268 +17,326 @@ open System.Linq.Expressions // ---------------------------------------------------------------------------- -/// 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>) = +type Grouping<'K, 'T>(key: 'K, values: seq<'T>) = interface System.Linq.IGrouping<'K, 'T> with member _.Key = key interface System.Collections.IEnumerable with - member _.GetEnumerator() = values.GetEnumerator() :> System.Collections.IEnumerator + member _.GetEnumerator() = + values.GetEnumerator() :> System.Collections.IEnumerator interface System.Collections.Generic.IEnumerable<'T> with - member _.GetEnumerator() = values.GetEnumerator() + 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 System.Collections.Concurrent.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.GetMethodFromHandle :?> System.Reflection.MethodInfo - let NewAnonymousObjectHelperMeth = + let NewAnonymousObjectHelperMeth = methodhandleof (fun x -> LeafExpressionConverter.NewAnonymousObjectHelper x) - |> System.Reflection.MethodInfo.GetMethodFromHandle + |> System.Reflection.MethodInfo.GetMethodFromHandle :?> System.Reflection.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 -> - propSetList (p :: acc) xs + | ((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, + System.Reflection.BindingFlags.Public + ||| System.Reflection.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) -> + RewriteTupleType ty (List.map2 ConvImmutableTypeToMutableType [ x1; x2; x3; x4; x5; x6; x7; TupleConv(x8 :: tail) ]) + | _ -> 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 + 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 -> + | 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 = + (System.Reflection.MethodInfo.GetMethodFromHandle mhandle) :?> System.Reflection.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 cf8ec3924..56465b1be 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 - // 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 + let dict = Dictionary comparer - 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 + // 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 + + 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,52 @@ 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 +299,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 +321,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 +331,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 +469,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 +481,356 @@ 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 +840,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 +871,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 +1016,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 +1064,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 +1133,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 +1167,91 @@ 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 +1261,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 +1491,7 @@ module Array = result [] - let sort array = + let sort array = checkNonNull "array" array let result = copy array sortInPlace result @@ -1041,144 +1500,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 +1700,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 +1719,80 @@ 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 +1800,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 +1811,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 +2046,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 0b64a6450..977f071d4 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,51 @@ 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 +884,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 +904,21 @@ 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 + | _ when Object.Equals(syncCtxt, currentSyncCtxt) && thread.Equals Thread.CurrentThread -> executeImmediately () + | _ -> trampolineHolder.PostOrQueueWithTrampoline syncCtxt action member _.PostOrQueueWithTrampoline res = trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> ctxt.cont res) @@ -873,25 +942,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 +969,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 +978,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 +1028,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 +1061,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) + + let invokeMeth = + (typeof>) + .GetMethod("Invoke", BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) + System.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 +1099,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 +1157,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 +1186,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 +1194,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 +1216,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 +1233,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 +1249,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 +1270,7 @@ module AsyncPrimitives = let DisposeTimer (timer: byref) = match timer with | None -> () - | Some t -> + | Some t -> timer <- None t.Dispose() @@ -1188,119 +1285,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 - match callback with - | null -> () - | d -> - // The IASyncResult becomes observable here - d.Invoke (s :> System.IAsyncResult) + member s.SetResult(v: AsyncResult<'T>) = + result.RegisterResult(v, reuseThread = true) |> unfake - 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" + match callback with + | null -> () + | d -> + // The IASyncResult becomes observable here + d.Invoke(s :> System.IAsyncResult) - member x.IsClosed = disposed + 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.Close() = - if not disposed then - disposed <- true - cts.Dispose() - result.Close() + member x.IsClosed = disposed - member x.Token = cts.Token + member x.Close() = + if not disposed then + disposed <- true + cts.Dispose() + result.Close() - member x.CancelAsync() = cts.Cancel() + member x.Token = cts.Token - member x.CheckForNotSynchronous() = - if not result.ResultAvailable then - completedSynchronously <- false + member x.CancelAsync() = + cts.Cancel() - interface System.IAsyncResult with - member _.IsCompleted = result.ResultAvailable - member _.CompletedSynchronously = completedSynchronously - member _.AsyncWaitHandle = result.GetWaitHandle() - member _.AsyncState = state + member x.CheckForNotSynchronous() = + if not result.ResultAvailable then + completedSynchronously <- false - interface System.IDisposable with - member x.Dispose() = x.Close() + 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() 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 +1426,44 @@ 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) 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 +1472,123 @@ 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 +1598,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 +1664,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 +1684,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 +1697,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 +1710,125 @@ 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 + 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 +1836,50 @@ 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 +1889,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 +1904,33 @@ 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 +1938,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 +1980,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 +1990,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 +2005,25 @@ 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(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, 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 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) - 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> + beginAction, AsBeginEndHelpers.endAction<'T>, AsBeginEndHelpers.cancelAction<'T> - static member AwaitEvent(event:IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = + static member AwaitEvent(event: IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = async { let! ct = cancellationTokenAsync let resultCell = new ResultCell<_>() @@ -1820,37 +2031,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 +2077,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 +2166,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 +2202,98 @@ 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 +2301,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 b08a19896..3094b9977 100644 --- a/src/FSharp.Core/collections.fs +++ b/src/FSharp.Core/collections.fs @@ -8,41 +8,58 @@ 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 054b31cbd..108dd9b88 100644 --- a/src/FSharp.Core/event.fs +++ b/src/FSharp.Core/event.fs @@ -17,138 +17,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) = + member x.Invoke(_sender: obj, args: 'Args) = observer.OnNext 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) = - 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 + (System.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 = + 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) + } + } [] -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/eventmodule.fs b/src/FSharp.Core/eventmodule.fs index b9776a692..cd9dc68a7 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 2c0c462a9..f7699ce66 100644 --- a/src/FSharp.Core/fslib-extra-pervasives.fs +++ b/src/FSharp.Core/fslib-extra-pervasives.fs @@ -16,112 +16,137 @@ 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 +160,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 +294,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 +325,204 @@ 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 cd8b7ae3a..bbefce300 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,236 @@ 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 +275,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 +302,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 +353,73 @@ 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 +428,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 +445,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 +459,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 +504,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 +525,74 @@ module List = list |> filter cached.Add [] - let where predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate 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) = + 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 +603,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 +613,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 +623,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 +632,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 +696,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 +708,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 +720,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 +733,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 +749,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 +762,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 +779,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 +793,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 +847,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/mailbox.fs b/src/FSharp.Core/mailbox.fs index 78035f347..15e2b639f 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,18 +193,17 @@ 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 false -> - return failwith "should not happen - waitOneNoTimeoutOrCancellation always returns true" + | Choice1Of2 true -> return! scan timeoutAsync timeoutCts + | Choice1Of2 false -> return failwith "should not happen - waitOneNoTimeoutOrCancellation always returns true" | Choice2Of2 () -> lock syncRoot (fun () -> // Cancel the outstanding wait for messages installed by waitOneWithCancellation @@ -214,13 +226,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 +245,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 +262,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 +278,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 +294,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 +309,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 +359,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 +379,116 @@ 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) + + return res + } - member x.PostAndAsyncReply(buildMessage, ?timeout:int) = + 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 msg = + buildMessage (new AsyncReplyChannel<_>(fun reply -> resultCell.RegisterResult(reply, reuseThread = false) |> ignore)) + 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 7a72f29b1..70f90a72d 100644 --- a/src/FSharp.Core/map.fs +++ b/src/FSharp.Core/map.fs @@ -17,38 +17,38 @@ 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 +64,440 @@ 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 + 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 () 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 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 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 - 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 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) - + 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> = + 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 -> 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 -> MapTree (k, v) + | 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 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) - if comparer.Compare(lo, hi) = 1 then x else foldFromTo f m x + 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 + + 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 +506,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 +601,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 +677,8 @@ type Map<[]'Key, [ + static let empty = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> new Map<'Key, 'Value>(comparer, MapTree.empty) [] @@ -598,18 +695,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 +719,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 +738,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 +809,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 +1106,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 +1163,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 +1175,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 +1205,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 +1218,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/math/z.fs b/src/FSharp.Core/math/z.fs index b79ad3671..28d0deead 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 4e5af5232..d1bcd1603 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 8b28af753..720ac9d1c 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 3ef11b97b..389ad12b7 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 _.ToString() = + name - override _.GetHashCode() = base.GetHashCode() + override _.GetHashCode() = + base.GetHashCode() - override v.Equals(obj:obj) = + 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,47 @@ 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 +286,157 @@ 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 +447,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 +473,317 @@ 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 +791,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 +834,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 +842,57 @@ 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 +915,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 +968,135 @@ 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 mkApplication v = checkAppliedLambda v; mkFE2 AppOp v + 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 mkApplication v = + checkAppliedLambda v + mkFE2 AppOp v let mkLetRaw v = mkFE2 LetOp v @@ -815,10 +1106,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 +1126,47 @@ 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 +1180,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 +1231,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 +1344,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 +1392,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 +1502,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 +1559,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 +1614,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 +1632,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 +1644,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 +1745,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 +1763,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 +1875,44 @@ 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)) | 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 +1925,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 +1945,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 +2033,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 +2056,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 +2115,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 +2139,151 @@ 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 +2304,45 @@ 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 +2355,362 @@ 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) + EA(LambdaTerm(v2, substituteInExpr bvs (fun v -> if v = bv then Some v2exp else tmsubst v) b), 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) /// 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 + 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 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) + mkStaticMethodCallW (methodInfo, methodInfoWithWitnesses, List.length witnesses, witnesses @ arguments) - static member CallWithWitnesses (obj: Expr, methodInfo: MethodInfo, methodInfoWithWitnesses: MethodInfo, 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 +2720,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 +2747,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 +2851,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 +2948,63 @@ 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 +3013,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 63b8d6d46..0a6fdd12e 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,171 @@ 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 expr = - Expression.Lambda> ( - Expression.Convert ( - Expression.Property ( - Expression.Convert (param, prop.DeclaringType), - prop), - typeof), - param) - expr.Compile () + Expression.Lambda>( + Expression.Convert(Expression.Property(Expression.Convert(param, prop.DeclaringType), prop), 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 + Expression.Convert(Expression.ArrayAccess(paramArray, Expression.Constant paramIndex), 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 + Expression.Convert(Expression.ArrayAccess(paramArray, Expression.Constant paramIndex), 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 - ), - elements - ) + 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 +237,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 + Expression.Assign( + outputArray, + Expression.NewArrayBounds(typeof, Expression.Constant(outputLength tupleEncField typ)) + ) + :> Expression + yield! writeTupleIntoArray typ (Expression.Convert(param, typ)) outputArray 0 yield 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) in 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 +280,73 @@ 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 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) + 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 variantNumberOfMember (x: MemberInfo) = let (_, _, vn) = findCompilationMappingAttributeFromMemberInfo x in vn + let sequenceNumberOfMember (x: MemberInfo) = + let (_, n, _) = findCompilationMappingAttributeFromMemberInfo x in n - let sortFreshArray f arr = Array.sortInPlaceWith f arr; arr + let variantNumberOfMember (x: MemberInfo) = + let (_, _, vn) = findCompilationMappingAttributeFromMemberInfo x in vn - let isFieldProperty (prop : PropertyInfo) = + let sortFreshArray f arr = + Array.sortInPlaceWith f arr + arr + + 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 +354,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 +379,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 +398,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 +411,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 +521,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,19 +569,22 @@ 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 -> invalidOp (String.Format(SR.GetString(SR.constructorForUnionCaseNotFound), methname)) | 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)) + (fun args -> meth.Invoke(null, BindingFlags.Static ||| BindingFlags.InvokeMethod ||| bindingFlags, null, args, null)) let getUnionCaseConstructorCompiled (typ: Type, tag: int, bindingFlags) = let meth = getUnionCaseConstructorMethod (typ, tag, bindingFlags) @@ -501,51 +592,56 @@ 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)) + invalidArg "unionType" (String.Format(SR.GetString(SR.privateUnionType), unionType.FullName)) else - invalidArg "unionType" (String.Format (SR.GetString (SR.notAUnionType), unionType.FullName)) + invalidArg "unionType" (String.Format(SR.GetString(SR.notAUnionType), unionType.FullName)) //----------------------------------------------------------------- // 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 +650,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 +679,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 +710,20 @@ 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)) + invalidArg "typ" (String.Format(SR.GetString(SR.notATupleType), typ.FullName)) + 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 +737,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 +770,60 @@ 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 + 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) + match ctor with - | null -> raise (ArgumentException (String.Format (SR.GetString (SR.invalidTupleTypeConstructorNotDefined), typ.FullName))) + | null -> raise (ArgumentException(String.Format(SR.GetString(SR.invalidTupleTypeConstructorNotDefined), 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 +831,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 +869,97 @@ 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())) + invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) 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())) + invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + 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())) + invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + 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 -> + raise + <| ArgumentException(String.Format(SR.GetString(SR.invalidRecordTypeConstructorNotDefined), typ.FullName)) | _ -> () + ctor - let getRecordConstructor(typ: Type, bindingFlags) = - let ctor = getRecordConstructorMethod(typ, bindingFlags) - (fun (args: obj[]) -> - ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| bindingFlags, null, args, null)) + let getRecordConstructor (typ: Type, bindingFlags) = + let ctor = getRecordConstructorMethod (typ, bindingFlags) + (fun (args: obj[]) -> 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 +969,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 +1001,24 @@ 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)) + invalidArg "exceptionType" (String.Format(SR.GetString(SR.privateExceptionType), exceptionType.FullName)) else - invalidArg "exceptionType" (String.Format (SR.GetString (SR.notAnExceptionType), exceptionType.FullName)) + invalidArg "exceptionType" (String.Format(SR.GetString(SR.notAnExceptionType), exceptionType.FullName)) 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)) + invalidArg argName (String.Format(SR.GetString(SR.privateRecordType), recordType.FullName)) else - invalidArg argName (String.Format (SR.GetString (SR.notARecordType), recordType.FullName)) + invalidArg argName (String.Format(SR.GetString(SR.notARecordType), recordType.FullName)) - 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)) + invalidArg argName (String.Format(SR.GetString(SR.notATupleType), tupleType.FullName)) [] type UnionCaseInfo(typ: System.Type, tag: int) = @@ -859,16 +1026,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 +1055,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 +1078,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 +1173,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 +1189,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 +1222,74 @@ 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)) + invalidArg "functionType" (String.Format(SR.GetString(SR.notAFunctionType), functionType.FullName)) + 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 + invalidArg "tuple" (String.Format(SR.GetString(SR.notATupleType), tuple.GetType().FullName)) + 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 + invalidArg "tuple" (String.Format(SR.GetString(SR.notATupleType), tuple.GetType().FullName)) + 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())) + invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), tuple.GetType().FullName, index.ToString())) + 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 +1301,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 +1318,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 +1334,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 +1351,80 @@ 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 ae9a7ca54..1f82740fa 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 02b896f62..3fd88f52c 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,29 +80,31 @@ 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 = + 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" [] - 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 @@ -114,23 +118,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,92 +151,111 @@ 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))) 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))) 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> = 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)) @@ -235,38 +263,51 @@ module ResumableCode = 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))) 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 +315,26 @@ 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 +344,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 27699c40a..7b867e661 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,26 @@ 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 +471,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 +479,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 +556,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 +756,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 +764,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 +779,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 +799,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 +841,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 +857,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 +886,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 +987,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 +1004,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 +1020,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 +1081,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 +1135,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 +1173,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 +1181,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 +1240,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 +1260,77 @@ 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 +1339,7 @@ module Seq = [] let sort source = checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray Array.stableSortInPlace array @@ -1162,6 +1348,7 @@ module Seq = [] let sortWith comparer source = checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray Array.stableSortInPlaceWith comparer array @@ -1170,175 +1357,240 @@ 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 +1598,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 +1612,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 +1686,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 +1730,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/set.fs b/src/FSharp.Core/set.fs index e59d30521..1734dc1a5 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 + + filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) - let filter comparer f s = filterAux comparer f s empty + let filter comparer f s = + filterAux comparer f s empty - let rec diffAux comparer (t:SetTree<'T>) acc = - if isEmpty acc then acc + 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 acc = + if mem comparer tn.Key b then + add comparer tn.Key acc + else + acc - let intersection comparer a b = intersectionAux comparer b a empty + 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 partition comparer f s = partitionAux comparer f s (empty, empty) + 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 rec minimumElementAux (t:SetTree<'T>) n = - if isEmpty t then n + let partition comparer f s = + partitionAux comparer f s (empty, empty) + + 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,161 @@ 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 + + iter + (fun x -> + arr.[j] <- x + j <- j + 1) + s - let toArray s = - let n = (count s) - let res = Array.zeroCreate n + 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 +711,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 +740,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 +797,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 +847,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() - let rec loop () = - let m1 = e1.MoveNext() + 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 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 +922,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/string.fs b/src/FSharp.Core/string.fs index f36e430e6..8580c6451 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 4ec83a25b..b34812114 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,15 +42,16 @@ 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) @@ -61,117 +62,137 @@ type TaskBuilderBase() = 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 +201,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 +215,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 +281,132 @@ 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 +414,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 -- GitLab