diff --git a/src/absil/ilprint.fs b/src/absil/ilprint.fs index 511d2f9e885..e2ed4e9302e 100644 --- a/src/absil/ilprint.fs +++ b/src/absil/ilprint.fs @@ -1,15 +1,15 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -module internal FSharp.Compiler.AbstractIL.ILAsciiWriter +module internal FSharp.Compiler.AbstractIL.ILAsciiWriter open Internal.Utilities -open FSharp.Compiler.AbstractIL -open FSharp.Compiler.AbstractIL.Internal +open FSharp.Compiler.AbstractIL +open FSharp.Compiler.AbstractIL.Internal open FSharp.Compiler.AbstractIL.Internal.Library -open FSharp.Compiler.AbstractIL.Diagnostics -open FSharp.Compiler.AbstractIL.Extensions.ILX.Types -open FSharp.Compiler.AbstractIL.Internal.AsciiConstants -open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.Diagnostics +open FSharp.Compiler.AbstractIL.Extensions.ILX.Types +open FSharp.Compiler.AbstractIL.Internal.AsciiConstants +open FSharp.Compiler.AbstractIL.IL open System.Text open System.IO @@ -18,23 +18,23 @@ open System.Reflection #if DEBUG let pretty () = true -// -------------------------------------------------------------------- +// -------------------------------------------------------------------- // Pretty printing // -------------------------------------------------------------------- -let tyvar_generator = - let i = ref 0 - fun n -> +let tyvar_generator = + let i = ref 0 + fun n -> incr i; n + string !i -// Carry an environment because the way we print method variables -// depends on the gparams of the current scope. -type ppenv = +// Carry an environment because the way we print method variables +// depends on the gparams of the current scope. +type ppenv = { ilGlobals: ILGlobals ppenvClassFormals: int ppenvMethodFormals: int } -let ppenv_enter_method mgparams env = +let ppenv_enter_method mgparams env = {env with ppenvMethodFormals=mgparams} let ppenv_enter_tdef gparams env = @@ -42,40 +42,40 @@ let ppenv_enter_tdef gparams env = let mk_ppenv ilg = { ilGlobals = ilg; ppenvClassFormals = 0; ppenvMethodFormals = 0 } -let debug_ppenv = mk_ppenv +let debug_ppenv = mk_ppenv let ppenv_enter_modul env = { env with ppenvClassFormals=0; ppenvMethodFormals=0 } -// -------------------------------------------------------------------- +// -------------------------------------------------------------------- // Pretty printing - output streams -// -------------------------------------------------------------------- +// -------------------------------------------------------------------- -let output_string (os: TextWriter) (s:string) = os.Write s +let output_string (os: TextWriter) (s:string) = os.Write s let output_char (os: TextWriter) (c:char) = os.Write c let output_int os (i:int) = output_string os (string i) -let output_hex_digit os i = +let output_hex_digit os i = assert (i >= 0 && i < 16) - if i > 9 then output_char os (char (int32 'A' + (i-10))) + if i > 9 then output_char os (char (int32 'A' + (i-10))) else output_char os (char (int32 '0' + i)) let output_qstring os s = output_char os '"' for i = 0 to String.length s - 1 do let c = String.get s i - if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then + if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then let c' = int32 c output_char os '\\' output_int os (c'/64) output_int os ((c' % 64) / 8) - output_int os (c' % 8) - else if (c = '"') then + output_int os (c' % 8) + else if (c = '"') then output_char os '\\'; output_char os '"' - else if (c = '\\') then + else if (c = '\\') then output_char os '\\'; output_char os '\\' - else + else output_char os c done output_char os '"' @@ -83,24 +83,24 @@ let output_sqstring os s = output_char os '\'' for i = 0 to String.length s - 1 do let c = s.[i] - if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then + if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then let c' = int32 c output_char os '\\' output_int os (c'/64) output_int os ((c' % 64) / 8) - output_int os (c' % 8) - else if (c = '\\') then + output_int os (c' % 8) + else if (c = '\\') then output_char os '\\'; output_char os '\\' - else if (c = '\'') then + else if (c = '\'') then output_char os '\\'; output_char os '\'' - else + else output_char os c done output_char os '\'' let output_seq sep f os (a:seq<_>) = use e = a.GetEnumerator() - if e.MoveNext() then + if e.MoveNext() then f os e.Current while e.MoveNext() do output_string os sep @@ -125,19 +125,19 @@ let output_label os n = output_string os n let output_lid os lid = output_seq "." output_string os lid -let string_of_type_name (_,n) = n +let string_of_type_name (_, n) = n -let output_byte os i = +let output_byte os i = output_hex_digit os (i / 16) output_hex_digit os (i % 16) -let output_bytes os (bytes:byte[]) = +let output_bytes os (bytes:byte[]) = for i = 0 to bytes.Length - 1 do output_byte os (Bytes.get bytes i) output_string os " " -let bits_of_float32 (x:float32) = System.BitConverter.ToInt32(System.BitConverter.GetBytes(x),0) +let bits_of_float32 (x:float32) = System.BitConverter.ToInt32(System.BitConverter.GetBytes(x), 0) let bits_of_float (x:float) = System.BitConverter.DoubleToInt64Bits(x) @@ -151,56 +151,56 @@ let output_i16 os (x:int16) = output_string os (string (int x)) let output_u32 os (x:uint32) = output_string os (string (int64 x)) -let output_i32 os (x:int32) = output_string os (string x) +let output_i32 os (x:int32) = output_string os (string x) let output_u64 os (x:uint64) = output_string os (string (int64 x)) -let output_i64 os (x:int64) = output_string os (string x) +let output_i64 os (x:int64) = output_string os (string x) let output_ieee32 os (x:float32) = output_string os "float32 ("; output_string os (string (bits_of_float32 x)); output_string os ")" let output_ieee64 os (x:float) = output_string os "float64 ("; output_string os (string (bits_of_float x)); output_string os ")" -let rec goutput_scoref _env os = function +let rec goutput_scoref _env os = function | ILScopeRef.Local -> () | ILScopeRef.Assembly aref -> output_string os "["; output_sqstring os aref.Name; output_string os "]" | ILScopeRef.Module mref -> - output_string os "[.module "; output_sqstring os mref.Name; output_string os "]" + output_string os "[.module "; output_sqstring os mref.Name; output_string os "]" -and goutput_type_name_ref env os (scoref,enc,n) = +and goutput_type_name_ref env os (scoref, enc, n) = goutput_scoref env os scoref output_seq "/" output_sqstring os (enc@[n]) -and goutput_tref env os (x:ILTypeRef) = - goutput_type_name_ref env os (x.Scope,x.Enclosing,x.Name) +and goutput_tref env os (x:ILTypeRef) = + goutput_type_name_ref env os (x.Scope, x.Enclosing, x.Name) and goutput_typ env os ty = - match ty with + match ty with | ILType.Boxed tr -> goutput_tspec env os tr - | ILType.TypeVar tv -> - // Special rule to print method type variables in Generic EE preferred form - // when an environment is available to help us do this. - let cgparams = env.ppenvClassFormals - let mgparams = env.ppenvMethodFormals - if int tv < cgparams then + | ILType.TypeVar tv -> + // Special rule to print method type variables in Generic EE preferred form + // when an environment is available to help us do this. + let cgparams = env.ppenvClassFormals + let mgparams = env.ppenvMethodFormals + if int tv < cgparams then output_string os "!" output_tyvar os tv - elif int tv - cgparams < mgparams then + elif int tv - cgparams < mgparams then output_string os "!!" output_int os (int tv - cgparams) - else + else output_string os "!" output_tyvar os tv output_int os (int tv) - + | ILType.Byref typ -> goutput_typ env os typ; output_string os "&" | ILType.Ptr typ -> goutput_typ env os typ; output_string os "*" - | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_SByte.TypeSpec.Name -> output_string os "int8" + | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_SByte.TypeSpec.Name -> output_string os "int8" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_Int16.TypeSpec.Name -> output_string os "int16" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_Int32.TypeSpec.Name -> output_string os "int32" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_Int64.TypeSpec.Name -> output_string os "int64" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_IntPtr.TypeSpec.Name -> output_string os "native int" - | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_Byte.TypeSpec.Name -> output_string os "unsigned int8" + | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_Byte.TypeSpec.Name -> output_string os "unsigned int8" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_UInt16.TypeSpec.Name -> output_string os "unsigned int16" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_UInt32.TypeSpec.Name -> output_string os "unsigned int32" | ILType.Value tspec when tspec.Name = EcmaMscorlibILGlobals.typ_UInt64.TypeSpec.Name -> output_string os "unsigned int64" @@ -215,7 +215,7 @@ and goutput_typ env os ty = output_string os " " goutput_gactuals env os tspec.GenericArgs | ILType.Void -> output_string os "void" - | ILType.Array (bounds,ty) -> + | ILType.Array (bounds, ty) -> goutput_typ env os ty output_string os "[" output_arr_bounds os bounds @@ -224,11 +224,11 @@ and goutput_typ env os ty = output_string os "method " goutput_typ env os csig.ReturnType output_string os " *(" - output_seq "," (goutput_typ env) os csig.ArgTypes + output_seq ", " (goutput_typ env) os csig.ArgTypes output_string os ")" | _ -> output_string os "NaT" - -and output_tyvar os d = + +and output_tyvar os d = output_u16 os d; () and goutput_ldtoken_info env os = function @@ -237,11 +237,11 @@ and goutput_ldtoken_info env os = function | ILToken.ILField x -> output_string os "field "; goutput_fspec env os x and goutput_typ_with_shortened_class_syntax env os = function - ILType.Boxed tspec when tspec.GenericArgs = [] -> + ILType.Boxed tspec when tspec.GenericArgs = [] -> goutput_tref env os tspec.TypeRef | typ2 -> goutput_typ env os typ2 -and goutput_gactuals env os inst = +and goutput_gactuals env os inst = if not (List.isEmpty inst) then output_string os "<" output_seq ", " (goutput_gactual env) os inst @@ -249,34 +249,34 @@ and goutput_gactuals env os inst = and goutput_gactual env os ty = goutput_typ env os ty -and goutput_tspec env os tspec = +and goutput_tspec env os tspec = output_string os "class " goutput_tref env os tspec.TypeRef output_string os " " goutput_gactuals env os tspec.GenericArgs -and output_arr_bounds os = function +and output_arr_bounds os = function | bounds when bounds = ILArrayShape.SingleDimensional -> () | ILArrayShape l -> - output_seq "," + output_seq ", " (fun os -> function - | (None,None) -> output_string os "" - | (None,Some sz) -> + | (None, None) -> output_string os "" + | (None, Some sz) -> output_int os sz - | (Some lower,None) -> + | (Some lower, None) -> output_int os lower output_string os " ... " - | (Some lower,Some d) -> + | (Some lower, Some d) -> output_int os lower output_string os " ... " output_int os d) - os + os l - -and goutput_permission _env os p = - let output_security_action os x = - output_string os - (match x with + +and goutput_permission _env os p = + let output_security_action os x = + output_string os + (match x with | ILSecurityAction.Request -> "request" | ILSecurityAction.Demand -> "demand" | ILSecurityAction.Assert-> "assert" @@ -291,32 +291,32 @@ and goutput_permission _env os p = | ILSecurityAction.PreJitDeny-> "prejitdeny" | ILSecurityAction.NonCasDemand-> "noncasdemand" | ILSecurityAction.NonCasLinkDemand-> "noncaslinkdemand" - | ILSecurityAction.NonCasInheritance-> "noncasinheritance" + | ILSecurityAction.NonCasInheritance-> "noncasinheritance" | ILSecurityAction.LinkDemandChoice -> "linkdemandchoice" | ILSecurityAction.InheritanceDemandChoice -> "inheritancedemandchoice" - | ILSecurityAction.DemandChoice -> "demandchoice") + | ILSecurityAction.DemandChoice -> "demandchoice") - match p with - | ILSecurityDecl (sa,b) -> + match p with + | ILSecurityDecl (sa, b) -> output_string os " .permissionset " - output_security_action os sa - output_string os " = (" - output_bytes os b - output_string os ")" - + output_security_action os sa + output_string os " = (" + output_bytes os b + output_string os ")" + and goutput_security_decls env os (ps: ILSecurityDecls) = output_seq " " (goutput_permission env) os ps.AsList -and goutput_gparam env os (gf: ILGenericParameterDef) = +and goutput_gparam env os (gf: ILGenericParameterDef) = output_string os (tyvar_generator gf.Name) - output_parens (output_seq "," (goutput_typ env)) os gf.Constraints + output_parens (output_seq ", " (goutput_typ env)) os gf.Constraints -and goutput_gparams env os b = - if not (isNil b) then - output_string os "<"; output_seq "," (goutput_gparam env) os b; output_string os ">"; () +and goutput_gparams env os b = + if not (isNil b) then + output_string os "<"; output_seq ", " (goutput_gparam env) os b; output_string os ">"; () and output_bcc os bcc = - output_string os - (match bcc with + output_string os + (match bcc with | ILArgConvention.FastCall -> "fastcall " | ILArgConvention.StdCall -> "stdcall " | ILArgConvention.ThisCall -> "thiscall " @@ -324,103 +324,103 @@ and output_bcc os bcc = | ILArgConvention.Default -> " " | ILArgConvention.VarArg -> "vararg ") -and output_callconv os (Callconv (hasthis,cc)) = - output_string os - (match hasthis with - ILThisConvention.Instance -> "instance " +and output_callconv os (Callconv (hasthis, cc)) = + output_string os + (match hasthis with + ILThisConvention.Instance -> "instance " | ILThisConvention.InstanceExplicit -> "explicit " - | ILThisConvention.Static -> "") + | ILThisConvention.Static -> "") output_bcc os cc -and goutput_dlocref env os (dref:ILType) = - match dref with - | dref when - dref.IsNominal && +and goutput_dlocref env os (dref:ILType) = + match dref with + | dref when + dref.IsNominal && isTypeNameForGlobalFunctions dref.TypeRef.Name && - dref.TypeRef.Scope = ILScopeRef.Local -> + dref.TypeRef.Scope = ILScopeRef.Local -> () - | dref when - dref.IsNominal && + | dref when + dref.IsNominal && isTypeNameForGlobalFunctions dref.TypeRef.Name -> goutput_scoref env os dref.TypeRef.Scope output_string os "::" - | ty ->goutput_typ_with_shortened_class_syntax env os ty; output_string os "::" + | ty ->goutput_typ_with_shortened_class_syntax env os ty; output_string os "::" and goutput_callsig env os (csig:ILCallingSignature) = output_callconv os csig.CallingConv output_string os " " goutput_typ env os csig.ReturnType - output_parens (output_seq "," (goutput_typ env)) os csig.ArgTypes + output_parens (output_seq ", " (goutput_typ env)) os csig.ArgTypes and goutput_mref env os (mref:ILMethodRef) = output_callconv os mref.CallingConv output_string os " " goutput_typ_with_shortened_class_syntax env os mref.ReturnType output_string os " " - // no quotes for ".ctor" - let name = mref.Name + // no quotes for ".ctor" + let name = mref.Name if name = ".ctor" || name = ".cctor" then output_string os name else output_id os name - output_parens (output_seq "," (goutput_typ env)) os mref.ArgTypes + output_parens (output_seq ", " (goutput_typ env)) os mref.ArgTypes -and goutput_mspec env os (mspec:ILMethodSpec) = - let fenv = +and goutput_mspec env os (mspec:ILMethodSpec) = + let fenv = ppenv_enter_method mspec.GenericArity - (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) + (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) output_callconv os mspec.CallingConv output_string os " " goutput_typ fenv os mspec.FormalReturnType output_string os " " goutput_dlocref env os mspec.DeclaringType output_string os " " - let name = mspec.Name + let name = mspec.Name if name = ".ctor" || name = ".cctor" then output_string os name else output_id os name goutput_gactuals env os mspec.GenericArgs - output_parens (output_seq "," (goutput_typ fenv)) os mspec.FormalArgTypes + output_parens (output_seq ", " (goutput_typ fenv)) os mspec.FormalArgTypes and goutput_vararg_mspec env os (mspec, varargs) = - match varargs with + match varargs with | None -> goutput_mspec env os mspec - | Some varargs' -> - let fenv = + | Some varargs' -> + let fenv = ppenv_enter_method mspec.GenericArity - (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) + (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) output_callconv os mspec.CallingConv output_string os " " goutput_typ fenv os mspec.FormalReturnType output_string os " " goutput_dlocref env os mspec.DeclaringType - let name = mspec.Name + let name = mspec.Name if name = ".ctor" || name = ".cctor" then output_string os name else output_id os name goutput_gactuals env os mspec.GenericArgs output_string os "(" - output_seq "," (goutput_typ fenv) os mspec.FormalArgTypes - output_string os ",...," - output_seq "," (goutput_typ fenv) os varargs' + output_seq ", " (goutput_typ fenv) os mspec.FormalArgTypes + output_string os ", ..., " + output_seq ", " (goutput_typ fenv) os varargs' output_string os ")" -and goutput_vararg_sig env os (csig:ILCallingSignature,varargs:ILVarArgs) = - match varargs with +and goutput_vararg_sig env os (csig:ILCallingSignature, varargs:ILVarArgs) = + match varargs with | None -> goutput_callsig env os csig; () - | Some varargs' -> + | Some varargs' -> goutput_typ env os csig.ReturnType output_string os " (" - let argtys = csig.ArgTypes + let argtys = csig.ArgTypes if argtys.Length <> 0 then output_seq ", " (goutput_typ env) os argtys - output_string os ",...," - output_seq "," (goutput_typ env) os varargs' + output_string os ", ..., " + output_seq ", " (goutput_typ env) os varargs' output_string os ")" and goutput_fspec env os (x:ILFieldSpec) = - let fenv = ppenv_enter_tdef (mkILFormalTypars x.DeclaringType.GenericArgs) env + let fenv = ppenv_enter_tdef (mkILFormalTypars x.DeclaringType.GenericArgs) env goutput_typ fenv os x.FormalType output_string os " " goutput_dlocref env os x.DeclaringType output_id os x.Name - -let output_member_access os access = - output_string os - (match access with + +let output_member_access os access = + output_string os + (match access with | ILMemberAccess.Public -> "public" | ILMemberAccess.Private -> "private" | ILMemberAccess.Family -> "family" @@ -429,14 +429,14 @@ let output_member_access os access = | ILMemberAccess.FamilyOrAssembly -> "famorassem" | ILMemberAccess.Assembly -> "assembly") -let output_type_access os access = - match access with +let output_type_access os access = + match access with | ILTypeDefAccess.Public -> output_string os "public" | ILTypeDefAccess.Private -> output_string os "private" | ILTypeDefAccess.Nested ilMemberAccess -> output_string os "nested "; output_member_access os ilMemberAccess -let output_encoding os e = - match e with +let output_encoding os e = + match e with | ILDefaultPInvokeEncoding.Ansi -> output_string os " ansi " | ILDefaultPInvokeEncoding.Auto -> output_string os " autochar " | ILDefaultPInvokeEncoding.Unicode -> output_string os " unicode " @@ -454,29 +454,29 @@ let output_field_init os = function | ILFieldInit.UInt64 x-> output_string os "= uint64"; output_parens output_u64 os x | ILFieldInit.Single x-> output_string os "= float32"; output_parens output_ieee32 os x | ILFieldInit.Double x-> output_string os "= float64"; output_parens output_ieee64 os x - | ILFieldInit.Null-> output_string os "= nullref" + | ILFieldInit.Null-> output_string os "= nullref" let output_at os b = Printf.fprintf os " at (* no labels for data available, data = %a *)" (output_parens output_bytes) b let output_option f os = function None -> () | Some x -> f os x - -let goutput_alternative_ref env os (alt: IlxUnionAlternative) = + +let goutput_alternative_ref env os (alt: IlxUnionAlternative) = output_id os alt.Name - alt.FieldDefs |> output_parens (output_array "," (fun os fdef -> goutput_typ env os fdef.Type)) os + alt.FieldDefs |> output_parens (output_array ", " (fun os fdef -> goutput_typ env os fdef.Type)) os -let goutput_curef env os (IlxUnionRef(_,tref,alts,_,_)) = +let goutput_curef env os (IlxUnionRef(_, tref, alts, _, _)) = output_string os " .classunion import " goutput_tref env os tref - output_parens (output_array "," (goutput_alternative_ref env)) os alts - -let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),i)) = + output_parens (output_array ", " (goutput_alternative_ref env)) os alts + +let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_, tref, _, _, _), i)) = output_string os "class /* classunion */ " goutput_tref env os tref goutput_gactuals env os i -let output_basic_type os x = - output_string os +let output_basic_type os x = + output_string os (match x with | DT_I1 -> "i1" | DT_U1 -> "u1" @@ -493,9 +493,9 @@ let output_basic_type os x = | DT_U -> "u" | DT_REF -> "ref") -let output_custom_attr_data os data = +let output_custom_attr_data os data = output_string os " = "; output_parens output_bytes os data - + let goutput_custom_attr env os (attr: ILAttribute) = output_string os " .custom " goutput_mspec env os attr.Method @@ -507,8 +507,8 @@ let goutput_custom_attrs env os (attrs : ILAttributes) = let goutput_fdef _tref env os (fd: ILFieldDef) = output_string os " .field " - match fd.Offset with Some i -> output_string os "["; output_i32 os i; output_string os "] " | None -> () - match fd.Marshal with Some _i -> output_string os "// marshal attribute not printed\n"; | None -> () + match fd.Offset with Some i -> output_string os "["; output_i32 os i; output_string os "] " | None -> () + match fd.Marshal with Some _i -> output_string os "// marshal attribute not printed\n"; | None -> () output_member_access os fd.Access output_string os " " if fd.IsStatic then output_string os " static " @@ -540,17 +540,17 @@ let output_after_tailcall os = function | Tailcall -> output_string os " ret " | _ -> () let rec goutput_apps env os = function - | Apps_tyapp (actual,cs) -> + | Apps_tyapp (actual, cs) -> output_angled (goutput_gactual env) os actual output_string os " " - output_angled (goutput_gparam env) os (mkILSimpleTypar "T") + output_angled (goutput_gparam env) os (mkILSimpleTypar "T") output_string os " " goutput_apps env os cs - | Apps_app(ty,cs) -> + | Apps_app(ty, cs) -> output_parens (goutput_typ env) os ty output_string os " " goutput_apps env os cs - | Apps_done ty -> + | Apps_done ty -> output_string os "--> " goutput_typ env os ty @@ -563,37 +563,37 @@ let output_short_i32 os i32 = if i32 < 256 && 0 >= i32 then (output_string os ".s "; output_i32 os i32) else output_string os " "; output_i32 os i32 -let output_code_label os lab = +let output_code_label os lab = output_string os (formatCodeLabel lab) -let goutput_local env os (l: ILLocal) = +let goutput_local env os (l: ILLocal) = goutput_typ env os l.Type if l.IsPinned then output_string os " pinned" -let goutput_param env os (l: ILParameter) = - match l.Name with +let goutput_param env os (l: ILParameter) = + match l.Name with None -> goutput_typ env os l.Type | Some n -> goutput_typ env os l.Type; output_string os " "; output_sqstring os n -let goutput_params env os ps = - output_parens (output_seq "," (goutput_param env)) os ps +let goutput_params env os ps = + output_parens (output_seq ", " (goutput_param env)) os ps -let goutput_freevar env os l = - goutput_typ env os l.fvType; output_string os " "; output_sqstring os l.fvName +let goutput_freevar env os l = + goutput_typ env os l.fvType; output_string os " "; output_sqstring os l.fvName -let goutput_freevars env os ps = - output_parens (output_seq "," (goutput_freevar env)) os ps +let goutput_freevars env os ps = + output_parens (output_seq ", " (goutput_freevar env)) os ps -let output_source os (s:ILSourceMarker) = - if s.Document.File <> "" then +let output_source os (s:ILSourceMarker) = + if s.Document.File <> "" then output_string os " .line " output_int os s.Line - if s.Column <> -1 then + if s.Column <> -1 then output_string os " : " output_int os s.Column output_string os " /* - " output_int os s.EndLine - if s.Column <> -1 then + if s.Column <> -1 then output_string os " : " output_int os s.EndColumn output_string os "*/ " @@ -604,9 +604,9 @@ let rec goutput_instr env os inst = match inst with | si when isNoArgInstr si -> output_lid os (wordsOfNoArgInstr si) - | I_brcmp (cmp,tg1) -> - output_string os - (match cmp with + | I_brcmp (cmp, tg1) -> + output_string os + (match cmp with | BI_beq -> "beq" | BI_bgt -> "bgt" | BI_bgt_un -> "bgt.un" @@ -623,159 +623,159 @@ let rec goutput_instr env os inst = output_code_label os tg1 | I_br tg -> output_string os "/* br "; output_code_label os tg; output_string os "*/" | I_leave tg -> output_string os "leave "; output_code_label os tg - | I_call (tl,mspec,varargs) -> + | I_call (tl, mspec, varargs) -> output_tailness os tl output_string os "call " - goutput_vararg_mspec env os (mspec,varargs) + goutput_vararg_mspec env os (mspec, varargs) output_after_tailcall os tl - | I_calli (tl,mref,varargs) -> + | I_calli (tl, mref, varargs) -> output_tailness os tl output_string os "calli " - goutput_vararg_sig env os (mref,varargs) + goutput_vararg_sig env os (mref, varargs) output_after_tailcall os tl | I_ldarg u16 -> output_string os "ldarg"; output_short_u16 os u16 | I_ldarga u16 -> output_string os "ldarga "; output_u16 os u16 - | (AI_ldc (dt, ILConst.I4 x)) -> + | (AI_ldc (dt, ILConst.I4 x)) -> output_string os "ldc."; output_basic_type os dt; output_short_i32 os x - | (AI_ldc (dt, ILConst.I8 x)) -> + | (AI_ldc (dt, ILConst.I8 x)) -> output_string os "ldc."; output_basic_type os dt; output_string os " "; output_i64 os x - | (AI_ldc (dt, ILConst.R4 x)) -> + | (AI_ldc (dt, ILConst.R4 x)) -> output_string os "ldc."; output_basic_type os dt; output_string os " "; output_ieee32 os x - | (AI_ldc (dt, ILConst.R8 x)) -> + | (AI_ldc (dt, ILConst.R8 x)) -> output_string os "ldc."; output_basic_type os dt; output_string os " "; output_ieee64 os x | I_ldftn mspec -> output_string os "ldftn "; goutput_mspec env os mspec | I_ldvirtftn mspec -> output_string os "ldvirtftn "; goutput_mspec env os mspec - | I_ldind (al,vol,dt) -> + | I_ldind (al, vol, dt) -> output_alignment os al output_volatility os vol output_string os "ldind." - output_basic_type os dt - | I_cpblk (al,vol) -> + output_basic_type os dt + | I_cpblk (al, vol) -> output_alignment os al output_volatility os vol output_string os "cpblk" - | I_initblk (al,vol) -> + | I_initblk (al, vol) -> output_alignment os al output_volatility os vol output_string os "initblk" | I_ldloc u16 -> output_string os "ldloc"; output_short_u16 os u16 | I_ldloca u16 -> output_string os "ldloca "; output_u16 os u16 | I_starg u16 -> output_string os "starg "; output_u16 os u16 - | I_stind (al,vol,dt) -> + | I_stind (al, vol, dt) -> output_alignment os al output_volatility os vol output_string os "stind." - output_basic_type os dt + output_basic_type os dt | I_stloc u16 -> output_string os "stloc"; output_short_u16 os u16 - | I_switch l -> output_string os "switch "; output_parens (output_seq "," output_code_label) os l - | I_callvirt (tl,mspec,varargs) -> + | I_switch l -> output_string os "switch "; output_parens (output_seq ", " output_code_label) os l + | I_callvirt (tl, mspec, varargs) -> output_tailness os tl output_string os "callvirt " - goutput_vararg_mspec env os (mspec,varargs) + goutput_vararg_mspec env os (mspec, varargs) output_after_tailcall os tl - | I_callconstraint (tl,ty,mspec,varargs) -> + | I_callconstraint (tl, ty, mspec, varargs) -> output_tailness os tl output_string os "constraint. " goutput_typ env os ty output_string os " callvirt " - goutput_vararg_mspec env os (mspec,varargs) + goutput_vararg_mspec env os (mspec, varargs) output_after_tailcall os tl | I_castclass ty -> output_string os "castclass "; goutput_typ env os ty | I_isinst ty -> output_string os "isinst "; goutput_typ env os ty - | I_ldfld (al,vol,fspec) -> + | I_ldfld (al, vol, fspec) -> output_alignment os al output_volatility os vol output_string os "ldfld " goutput_fspec env os fspec - | I_ldflda fspec -> - output_string os "ldflda " + | I_ldflda fspec -> + output_string os "ldflda " goutput_fspec env os fspec - | I_ldsfld (vol,fspec) -> + | I_ldsfld (vol, fspec) -> output_volatility os vol output_string os "ldsfld " goutput_fspec env os fspec - | I_ldsflda fspec -> + | I_ldsflda fspec -> output_string os "ldsflda " goutput_fspec env os fspec - | I_stfld (al,vol,fspec) -> + | I_stfld (al, vol, fspec) -> output_alignment os al output_volatility os vol output_string os "stfld " goutput_fspec env os fspec - | I_stsfld (vol,fspec) -> + | I_stsfld (vol, fspec) -> output_volatility os vol output_string os "stsfld " goutput_fspec env os fspec - | I_ldtoken tok -> output_string os "ldtoken "; goutput_ldtoken_info env os tok + | I_ldtoken tok -> output_string os "ldtoken "; goutput_ldtoken_info env os tok | I_refanyval ty -> output_string os "refanyval "; goutput_typ env os ty | I_refanytype -> output_string os "refanytype" | I_mkrefany typ -> output_string os "mkrefany "; goutput_typ env os typ - | I_ldstr s -> + | I_ldstr s -> output_string os "ldstr " output_string os s - | I_newobj (mspec,varargs) -> - // newobj: IL has a special rule that the CC is always implicitly "instance" and need - // not be mentioned explicitly + | I_newobj (mspec, varargs) -> + // newobj: IL has a special rule that the CC is always implicitly "instance" and need + // not be mentioned explicitly output_string os "newobj " - goutput_vararg_mspec env os (mspec,varargs) - | I_stelem dt -> output_string os "stelem."; output_basic_type os dt - | I_ldelem dt -> output_string os "ldelem."; output_basic_type os dt + goutput_vararg_mspec env os (mspec, varargs) + | I_stelem dt -> output_string os "stelem."; output_basic_type os dt + | I_ldelem dt -> output_string os "ldelem."; output_basic_type os dt - | I_newarr (shape,typ) -> - if shape = ILArrayShape.SingleDimensional then + | I_newarr (shape, typ) -> + if shape = ILArrayShape.SingleDimensional then output_string os "newarr " goutput_typ_with_shortened_class_syntax env os typ - else + else output_string os "newobj void " - goutput_dlocref env os (mkILArrTy(typ,shape)) + goutput_dlocref env os (mkILArrTy(typ, shape)) output_string os ".ctor" - let rank = shape.Rank - output_parens (output_array "," (goutput_typ env)) os (Array.create ( rank) EcmaMscorlibILGlobals.typ_Int32) - | I_stelem_any (shape,dt) -> - if shape = ILArrayShape.SingleDimensional then - output_string os "stelem.any "; goutput_typ env os dt - else + let rank = shape.Rank + output_parens (output_array ", " (goutput_typ env)) os (Array.create ( rank) EcmaMscorlibILGlobals.typ_Int32) + | I_stelem_any (shape, dt) -> + if shape = ILArrayShape.SingleDimensional then + output_string os "stelem.any "; goutput_typ env os dt + else output_string os "call instance void " - goutput_dlocref env os (mkILArrTy(dt,shape)) + goutput_dlocref env os (mkILArrTy(dt, shape)) output_string os "Set" - let rank = shape.Rank + let rank = shape.Rank let arr = Array.create (rank + 1) EcmaMscorlibILGlobals.typ_Int32 arr.[rank] <- dt - output_parens (output_array "," (goutput_typ env)) os arr - | I_ldelem_any (shape,tok) -> - if shape = ILArrayShape.SingleDimensional then - output_string os "ldelem.any "; goutput_typ env os tok - else + output_parens (output_array ", " (goutput_typ env)) os arr + | I_ldelem_any (shape, tok) -> + if shape = ILArrayShape.SingleDimensional then + output_string os "ldelem.any "; goutput_typ env os tok + else output_string os "call instance " goutput_typ env os tok output_string os " " - goutput_dlocref env os (mkILArrTy(tok,shape)) + goutput_dlocref env os (mkILArrTy(tok, shape)) output_string os "Get" - let rank = shape.Rank - output_parens (output_array "," (goutput_typ env)) os (Array.create ( rank) EcmaMscorlibILGlobals.typ_Int32) - | I_ldelema (ro,_,shape,tok) -> + let rank = shape.Rank + output_parens (output_array ", " (goutput_typ env)) os (Array.create ( rank) EcmaMscorlibILGlobals.typ_Int32) + | I_ldelema (ro, _, shape, tok) -> if ro = ReadonlyAddress then output_string os "readonly. " - if shape = ILArrayShape.SingleDimensional then - output_string os "ldelema "; goutput_typ env os tok - else + if shape = ILArrayShape.SingleDimensional then + output_string os "ldelema "; goutput_typ env os tok + else output_string os "call instance " goutput_typ env os (ILType.Byref tok) output_string os " " - goutput_dlocref env os (mkILArrTy(tok,shape)) + goutput_dlocref env os (mkILArrTy(tok, shape)) output_string os "Address" - let rank = shape.Rank - output_parens (output_array "," (goutput_typ env)) os (Array.create ( rank) EcmaMscorlibILGlobals.typ_Int32) - + let rank = shape.Rank + output_parens (output_array ", " (goutput_typ env)) os (Array.create ( rank) EcmaMscorlibILGlobals.typ_Int32) + | I_box tok -> output_string os "box "; goutput_typ env os tok | I_unbox tok -> output_string os "unbox "; goutput_typ env os tok | I_unbox_any tok -> output_string os "unbox.any "; goutput_typ env os tok | I_initobj tok -> output_string os "initobj "; goutput_typ env os tok - | I_ldobj (al,vol,tok) -> + | I_ldobj (al, vol, tok) -> output_alignment os al output_volatility os vol output_string os "ldobj " goutput_typ env os tok - | I_stobj (al,vol,tok) -> + | I_stobj (al, vol, tok) -> output_alignment os al output_volatility os vol output_string os "stobj " @@ -784,7 +784,7 @@ let rec goutput_instr env os inst = | I_sizeof tok -> output_string os "sizeof "; goutput_typ env os tok | I_seqpoint s -> output_source os s | EI_ilzero ty -> output_string os "ilzero "; goutput_typ env os ty - | _ -> + | _ -> output_string os "" @@ -793,31 +793,31 @@ let goutput_ilmbody env os (il: ILMethodBody) = output_string os " .maxstack " output_i32 os il.MaxStack output_string os "\n" - if il.Locals.Length <> 0 then + if il.Locals.Length <> 0 then output_string os " .locals(" - output_seq ",\n " (goutput_local env) os il.Locals + output_seq ", \n " (goutput_local env) os il.Locals output_string os ")\n" - + let goutput_mbody is_entrypoint env os (md: ILMethodDef) = if md.ImplAttributes &&& MethodImplAttributes.Native <> enum 0 then output_string os "native " elif md.ImplAttributes &&& MethodImplAttributes.IL <> enum 0 then output_string os "cil " else output_string os "runtime " - + output_string os (if md.IsInternalCall then "internalcall " else " ") output_string os (if md.IsManaged then "managed " else " ") output_string os (if md.IsForwardRef then "forwardref " else " ") - output_string os " \n{ \n" + output_string os " \n{ \n" goutput_security_decls env os md.SecurityDecls goutput_custom_attrs env os md.CustomAttrs - match md.Body.Contents with + match md.Body.Contents with | MethodBody.IL il -> goutput_ilmbody env os il | _ -> () if is_entrypoint then output_string os " .entrypoint" output_string os "\n" output_string os "}\n" - + let goutput_mdef env os (md:ILMethodDef) = - let attrs = + let attrs = if md.IsVirtual then "virtual " + (if md.IsFinal then "final " else "") + @@ -829,18 +829,18 @@ let goutput_mdef env os (md:ILMethodDef) = elif md.IsConstructor then "rtspecialname" elif md.IsStatic then "static " + - (match md.Body.Contents with - MethodBody.PInvoke (attr) -> + (match md.Body.Contents with + MethodBody.PInvoke (attr) -> "pinvokeimpl(\"" + attr.Where.Name + "\" as \"" + attr.Name + "\"" + - (match attr.CallingConv with + (match attr.CallingConv with | PInvokeCallingConvention.None -> "" | PInvokeCallingConvention.Cdecl -> " cdecl" | PInvokeCallingConvention.Stdcall -> " stdcall" - | PInvokeCallingConvention.Thiscall -> " thiscall" + | PInvokeCallingConvention.Thiscall -> " thiscall" | PInvokeCallingConvention.Fastcall -> " fastcall" | PInvokeCallingConvention.WinApi -> " winapi" ) + - (match attr.CharEncoding with + (match attr.CharEncoding with | PInvokeCharEncoding.None -> "" | PInvokeCharEncoding.Ansi -> " ansi" | PInvokeCharEncoding.Unicode -> " unicode" @@ -849,12 +849,12 @@ let goutput_mdef env os (md:ILMethodDef) = (if attr.NoMangle then " nomangle" else "") + (if attr.LastError then " lasterr" else "") + ")" - | _ -> + | _ -> "") - elif md.IsClassInitializer then "specialname rtspecialname static" + elif md.IsClassInitializer then "specialname rtspecialname static" else "" - let is_entrypoint = md.IsEntryPoint - let menv = ppenv_enter_method (List.length md.GenericParams) env + let is_entrypoint = md.IsEntryPoint + let menv = ppenv_enter_method (List.length md.GenericParams) env output_string os " .method " if md.IsHideBySig then output_string os "hidebysig " if md.IsReqSecObj then output_string os "reqsecobj " @@ -868,7 +868,7 @@ let goutput_mdef env os (md:ILMethodDef) = output_string os " " (goutput_typ menv) os md.Return.Type output_string os " " - output_id os md.Name + output_id os md.Name output_string os " " (goutput_gparams env) os md.GenericParams output_string os " " @@ -888,19 +888,19 @@ let goutput_pdef env os (pd: ILPropertyDef) = output_string os "\n\tsetter: " (match pd.SetMethod with None -> () | Some mref -> goutput_mref env os mref) -let goutput_superclass env os = function +let goutput_superclass env os = function None -> () | Some typ -> output_string os "extends "; (goutput_typ_with_shortened_class_syntax env) os typ let goutput_superinterfaces env os imp = if not (List.isEmpty imp) then output_string os "implements " - output_seq "," (goutput_typ_with_shortened_class_syntax env) os imp + output_seq ", " (goutput_typ_with_shortened_class_syntax env) os imp let goutput_implements env os (imp:ILTypes) = if not (List.isEmpty imp) then output_string os "implements " - output_seq "," (goutput_typ_with_shortened_class_syntax env) os imp + output_seq ", " (goutput_typ_with_shortened_class_syntax env) os imp let the = function Some x -> x | None -> failwith "the" @@ -909,29 +909,29 @@ let output_type_layout_info os info = if info.Pack <> None then (output_string os " .pack "; output_u16 os (the info.Pack)) let splitTypeLayout = function - | ILTypeDefLayout.Auto -> "auto",(fun _os () -> ()) + | ILTypeDefLayout.Auto -> "auto", (fun _os () -> ()) | ILTypeDefLayout.Sequential info -> "sequential", (fun os () -> output_type_layout_info os info) | ILTypeDefLayout.Explicit info -> "explicit", (fun os () -> output_type_layout_info os info) - -let goutput_fdefs tref env os (fdefs: ILFieldDefs) = + +let goutput_fdefs tref env os (fdefs: ILFieldDefs) = List.iter (fun f -> (goutput_fdef tref env) os f; output_string os "\n" ) fdefs.AsList -let goutput_mdefs env os (mdefs: ILMethodDefs) = +let goutput_mdefs env os (mdefs: ILMethodDefs) = Array.iter (fun f -> (goutput_mdef env) os f; output_string os "\n" ) mdefs.AsArray -let goutput_pdefs env os (pdefs: ILPropertyDefs) = +let goutput_pdefs env os (pdefs: ILPropertyDefs) = List.iter (fun f -> (goutput_pdef env) os f; output_string os "\n" ) pdefs.AsList let rec goutput_tdef enc env contents os (cd: ILTypeDef) = - let env = ppenv_enter_tdef cd.GenericParams env - let layout_attr,pp_layout_decls = splitTypeLayout cd.Layout - if isTypeNameForGlobalFunctions cd.Name then - if contents then - let tref = (mkILNestedTyRef (ILScopeRef.Local,enc,cd.Name)) + let env = ppenv_enter_tdef cd.GenericParams env + let layout_attr, pp_layout_decls = splitTypeLayout cd.Layout + if isTypeNameForGlobalFunctions cd.Name then + if contents then + let tref = (mkILNestedTyRef (ILScopeRef.Local, enc, cd.Name)) goutput_mdefs env os cd.Methods goutput_fdefs tref env os cd.Fields goutput_pdefs env os cd.Properties - else + else output_string os "\n" if cd.IsInterface then output_string os ".class interface " else output_string os ".class " @@ -947,15 +947,15 @@ let rec goutput_tdef enc env contents os (cd: ILTypeDef) = if cd.IsAbstract then output_string os "abstract " if cd.IsSerializable then output_string os "serializable " if cd.IsComInterop then output_string os "import " - output_sqstring os cd.Name + output_sqstring os cd.Name goutput_gparams env os cd.GenericParams output_string os "\n\t" goutput_superclass env os cd.Extends output_string os "\n\t" goutput_implements env os cd.Implements output_string os "\n{\n " - if contents then - let tref = (mkILNestedTyRef (ILScopeRef.Local,enc,cd.Name)) + if contents then + let tref = (mkILNestedTyRef (ILScopeRef.Local, enc, cd.Name)) goutput_custom_attrs env os cd.CustomAttrs goutput_security_decls env os cd.SecurityDecls pp_layout_decls os () @@ -967,18 +967,18 @@ let rec goutput_tdef enc env contents os (cd: ILTypeDef) = and output_init_semantics os f = if f &&& TypeAttributes.BeforeFieldInit <> enum 0 then output_string os "beforefieldinit" -and goutput_lambdas env os lambdas = +and goutput_lambdas env os lambdas = match lambdas with - | Lambdas_forall (gf,l) -> + | Lambdas_forall (gf, l) -> output_angled (goutput_gparam env) os gf output_string os " " (goutput_lambdas env) os l - | Lambdas_lambda (ps,l) -> + | Lambdas_lambda (ps, l) -> output_parens (goutput_param env) os ps output_string os " " (goutput_lambdas env) os l | Lambdas_return typ -> output_string os "--> "; (goutput_typ env) os typ - + and goutput_tdefs contents enc env os (td: ILTypeDefs) = List.iter (goutput_tdef enc env contents os) td.AsList @@ -994,12 +994,12 @@ let output_ver os (version: ILVersionInfo) = let output_locale os s = output_string os " .Locale "; output_qstring os s -let output_hash os x = - output_string os " .hash = "; output_parens output_bytes os x -let output_publickeytoken os x = - output_string os " .publickeytoken = "; output_parens output_bytes os x -let output_publickey os x = - output_string os " .publickey = "; output_parens output_bytes os x +let output_hash os x = + output_string os " .hash = "; output_parens output_bytes os x +let output_publickeytoken os x = + output_string os " .publickeytoken = "; output_parens output_bytes os x +let output_publickey os x = + output_string os " .publickey = "; output_parens output_bytes os x let output_publickeyinfo os = function | PublicKey k -> output_publickey os k @@ -1021,29 +1021,29 @@ let output_modref os (modref:ILModuleRef) = output_sqstring os modref.Name output_option output_hash os modref.Hash -let goutput_resource env os r = +let goutput_resource env os r = output_string os " .mresource " output_string os (match r.Access with ILResourceAccess.Public -> " public " | ILResourceAccess.Private -> " private ") output_sqstring os r.Name output_string os " { " goutput_custom_attrs env os r.CustomAttrs - match r.Location with - | ILResourceLocation.LocalIn _ - | ILResourceLocation.LocalOut _ -> + match r.Location with + | ILResourceLocation.LocalIn _ + | ILResourceLocation.LocalOut _ -> output_string os " /* loc nyi */ " - | ILResourceLocation.File (mref,off) -> + | ILResourceLocation.File (mref, off) -> output_string os " .file " output_sqstring os mref.Name output_string os " at " - output_i32 os off - | ILResourceLocation.Assembly aref -> + output_i32 os off + | ILResourceLocation.Assembly aref -> output_string os " .assembly extern " output_sqstring os aref.Name output_string os " }\n " -let goutput_manifest env os m = +let goutput_manifest env os m = output_string os " .assembly " - match m.AssemblyLongevity with + match m.AssemblyLongevity with | ILAssemblyLongevity.Unspecified -> () | ILAssemblyLongevity.Library -> output_string os "library " | ILAssemblyLongevity.PlatformAppDomain -> output_string os "platformappdomain " @@ -1060,25 +1060,25 @@ let goutput_manifest env os m = let output_module_fragment_aux _refs os (ilg: ILGlobals) modul = - try + try let env = mk_ppenv ilg - let env = ppenv_enter_modul env + let env = ppenv_enter_modul env goutput_tdefs false ([]) env os modul.TypeDefs goutput_tdefs true ([]) env os modul.TypeDefs - with e -> + with e -> output_string os "*** Error during printing : "; output_string os (e.ToString()); os.Flush() reraise() let output_module_fragment os (ilg: ILGlobals) modul = - let refs = computeILRefs modul + let refs = computeILRefs modul output_module_fragment_aux refs os ilg modul refs -let output_module_refs os refs = +let output_module_refs os refs = List.iter (fun x -> output_assemblyRef os x; output_string os "\n") refs.AssemblyReferences List.iter (fun x -> output_modref os x; output_string os "\n") refs.ModuleReferences - -let goutput_module_manifest env os modul = + +let goutput_module_manifest env os modul = output_string os " .module "; output_sqstring os modul.Name goutput_custom_attrs env os modul.CustomAttrs output_string os " .imagebase "; output_i32 os modul.ImageBase @@ -1090,20 +1090,20 @@ let goutput_module_manifest env os modul = output_option (goutput_manifest env) os modul.Manifest let output_module os (ilg: ILGlobals) modul = - try - let refs = computeILRefs modul + try + let refs = computeILRefs modul let env = mk_ppenv ilg - let env = ppenv_enter_modul env + let env = ppenv_enter_modul env output_module_refs os refs goutput_module_manifest env os modul output_module_fragment_aux refs os ilg modul - with e -> + with e -> output_string os "*** Error during printing : "; output_string os (e.ToString()); os.Flush() raise e #endif - - - + + + diff --git a/src/fsharp/FSharp.Core/Linq.fs b/src/fsharp/FSharp.Core/Linq.fs index 8b6b5124c4d..84802d1cd11 100644 --- a/src/fsharp/FSharp.Core/Linq.fs +++ b/src/fsharp/FSharp.Core/Linq.fs @@ -49,93 +49,101 @@ module NullableOperators = 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 = - open System - - [] - 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 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 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 int (value:Nullable<_>) = if value.HasValue then Nullable(Operators.int value.Value) else Nullable() - - [] - let inline enum (value:Nullable< int32 >) = 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 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 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 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 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 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 char (value:Nullable<_>) = if value.HasValue then Nullable(Operators.char value.Value) else Nullable() + open System + + [] + 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 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 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 int (value:Nullable<_>) = if value.HasValue then Nullable(Operators.int value.Value) else Nullable() + + [] + let inline enum (value:Nullable< int32 >) = 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 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 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 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 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 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 char (value:Nullable<_>) = if value.HasValue then Nullable(Operators.char value.Value) else Nullable() namespace Microsoft.FSharp.Linq.RuntimeHelpers @@ -162,17 +170,17 @@ open ReflectionAdapters module LeafExpressionConverter = // The following is recognized as a LINQ 'member initialization pattern' in a quotation. - let MemberInitializationHelper (_x:'T) : 'T = raise (NotSupportedException "This function should not be called directly") + let MemberInitializationHelper (_x:'T) : 'T = raise (NotSupportedException "This function should not be called directly") // The following is recognized as a LINQ 'member initialization pattern' in a quotation. - let NewAnonymousObjectHelper (_x:'T) : 'T = raise (NotSupportedException "This function should not be called directly") + let NewAnonymousObjectHelper (_x:'T) : 'T = raise (NotSupportedException "This function should not be called directly") // This is used to mark expressions inserted to satisfy C#'s design where, inside C#-compiler generated // LINQ expressions, they pass an argument or type T to an argument expecting Expression. let ImplicitExpressionConversionHelper (_x:'T) : Expression<'T> = raise (NotSupportedException "This function should not be called directly") - [] - type ConvEnv = + [] + type ConvEnv = { varEnv : Map } let asExpr x = (x :> Expression) @@ -181,182 +189,182 @@ module LeafExpressionConverter = let isNamedType(typ:Type) = not (typ.IsArray || typ.IsByRef || typ.IsPointer) - let equivHeadTypes (ty1:Type) (ty2:Type) = + let equivHeadTypes (ty1:Type) (ty2:Type) = isNamedType(ty1) && - if ty1.IsGenericType then + if ty1.IsGenericType then ty2.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(ty2.GetGenericTypeDefinition()) - else + else ty1.Equals(ty2) let isFunctionType typ = equivHeadTypes typ (typeof<(int -> int)>) - let getFunctionType typ = + let getFunctionType typ = if not (isFunctionType typ) then invalidArg "typ" "cannot convert recursion except for function types" let tyargs = typ.GetGenericArguments() tyargs.[0], tyargs.[1] - - let GetGenericMethodDefinition (methInfo:MethodInfo) = + + let GetGenericMethodDefinition (methInfo:MethodInfo) = if methInfo.IsGenericMethod then methInfo.GetGenericMethodDefinition() else methInfo - let StringConcat = - methodhandleof (fun (x:obj, y:obj) -> String.Concat (x,y)) + let StringConcat = + methodhandleof (fun (x:obj, y:obj) -> String.Concat (x, y)) |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo - - let SubstHelperRaw (q:Expr, x:Var[], y:obj[]) : Expr = - let d = Map.ofArray (Array.zip x y) + + let SubstHelperRaw (q:Expr, x:Var[], y:obj[]) : Expr = + let d = Map.ofArray (Array.zip x y) q.Substitute(fun v -> v |> d.TryFind |> Option.map (fun x -> Expr.Value(x, v.Type))) - - let SubstHelper<'T> (q:Expr, x:Var[], y:obj[]) : Expr<'T> = SubstHelperRaw(q,x,y) |> Expr.Cast - - let showAll = + + let SubstHelper<'T> (q:Expr, x:Var[], y:obj[]) : Expr<'T> = + SubstHelperRaw(q, x, y) |> Expr.Cast + + let showAll = #if FX_RESHAPED_REFLECTION true #else - BindingFlags.Public ||| BindingFlags.NonPublic + BindingFlags.Public ||| BindingFlags.NonPublic #endif - let NullableConstructor = typedefof>.GetConstructors().[0] + let NullableConstructor = + typedefof>.GetConstructors().[0] let SpecificCallToMethodInfo (minfo: System.Reflection.MethodInfo) = - let isg1 = minfo.IsGenericMethod + let isg1 = minfo.IsGenericMethod let gmd = if isg1 then minfo.GetGenericMethodDefinition() else null - (fun tm -> + (fun tm -> match tm with - | Call(obj,minfo2,args) + | Call(obj, minfo2, args) when ( #if !FX_NO_REFLECTION_METADATA_TOKENS minfo.MetadataToken = minfo2.MetadataToken && #endif if isg1 then minfo2.IsGenericMethod && gmd = minfo2.GetGenericMethodDefinition() else minfo = minfo2 - ) -> - Some(obj,(minfo2.GetGenericArguments() |> Array.toList),args) + ) -> + Some (obj, (minfo2.GetGenericArguments() |> Array.toList), args) | _ -> None) - let (|SpecificCallToMethod|_|) (mhandle: System.RuntimeMethodHandle) = + let (|SpecificCallToMethod|_|) (mhandle: System.RuntimeMethodHandle) = let minfo = (System.Reflection.MethodInfo.GetMethodFromHandle mhandle) :?> MethodInfo SpecificCallToMethodInfo minfo - let (|GenericEqualityQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> LanguagePrimitives.GenericEquality x y)) - let (|EqualsQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x = y)) - let (|GreaterQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x > y)) - let (|GreaterEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x >= y)) - let (|LessQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x < y)) - let (|LessEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x <= y)) - let (|NotEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x <> y)) - - let (|StaticEqualsQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int,y:int) -> NonStructuralComparison.(=) x y)) - let (|StaticGreaterQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int,y:int) -> NonStructuralComparison.(>) x y)) - let (|StaticGreaterEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int,y:int) -> NonStructuralComparison.(>=) x y)) - let (|StaticLessQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int,y:int) -> NonStructuralComparison.(<) x y)) - let (|StaticLessEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int,y:int) -> NonStructuralComparison.(<=) x y)) - let (|StaticNotEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int,y:int) -> NonStructuralComparison.(<>) x y)) - - let (|NullableEqualsQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?= ) x y)) - let (|NullableNotEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?<> ) x y)) - let (|NullableGreaterQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?> ) x y)) - let (|NullableGreaterEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?>= ) x y)) - let (|NullableLessQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?< ) x y)) - let (|NullableLessEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?<= ) x y)) - - let (|NullableEqualsNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?=? ) x y)) - let (|NullableNotEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?<>? ) x y)) - let (|NullableGreaterNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?>? ) x y)) - let (|NullableGreaterEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?>=? ) x y)) - let (|NullableLessNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ? NullableOperators.( ?<=? ) x y)) - - let (|EqualsNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( =? ) x y)) - let (|NotEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( <>? ) x y)) - let (|GreaterNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( >? ) x y)) - let (|GreaterEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( >=? ) x y)) - let (|LessNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( NullableOperators.( <=? ) x y)) - - let (|MakeDecimalQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (a1,a2,a3,a4,a5) -> LanguagePrimitives.IntrinsicFunctions.MakeDecimal a1 a2 a3 a4 a5)) - - - let (|NullablePlusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?+ ) x y)) - let (|NullablePlusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?+? ) x y)) - let (|PlusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( +? ) x y)) - - let (|NullableMinusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?- ) x y)) - let (|NullableMinusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?-? ) x y)) - let (|MinusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( -? ) x y)) - - let (|NullableMultiplyQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?* ) x y)) - let (|NullableMultiplyNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?*? ) x y)) - let (|MultiplyNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( *? ) x y)) - - let (|NullableDivideQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?/ ) x y)) - let (|NullableDivideNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?/? ) x y)) - let (|DivideNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( /? ) x y)) - - let (|NullableModuloQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?% ) x y)) - let (|NullableModuloNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( ?%? ) x y)) - let (|ModuloNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> NullableOperators.( %? ) x y)) - - let (|NotQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> not x)) - let (|NegQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int) -> -x)) - let (|PlusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x + y)) - let (|DivideQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x / y)) - let (|MinusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x - y)) - let (|MultiplyQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x * y)) - let (|ModuloQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x % y)) - let (|ShiftLeftQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x <<< y)) - let (|ShiftRightQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x >>> y)) - let (|BitwiseAndQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x &&& y)) - let (|BitwiseOrQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x ||| y)) - let (|BitwiseXorQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> x ^^^ y)) - let (|BitwiseNotQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> ~~~ x)) - let (|CheckedNeg|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Checked.( ~-) x)) - let (|CheckedPlusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> Checked.( + ) x y)) - let (|CheckedMinusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> Checked.( - ) x y)) - let (|CheckedMultiplyQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> Checked.( * ) x y)) - - let (|ConvCharQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.char x)) - let (|ConvDecimalQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.decimal x)) - let (|ConvFloatQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.float x)) - let (|ConvFloat32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.float32 x)) - let (|ConvSByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.sbyte x)) - - - let (|ConvInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int16 x)) - let (|ConvInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int32 x)) - let (|ConvIntQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int x)) - let (|ConvInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int64 x)) - let (|ConvByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.byte x)) - let (|ConvUInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.uint16 x)) - let (|ConvUInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.uint32 x)) - let (|ConvUInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.uint64 x)) - - let (|ConvInt8Q|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToSByte")) - let (|ConvUInt8Q|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToByte")) - let (|ConvDoubleQ|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToDouble")) - let (|ConvSingleQ|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToSingle")) - - let (|ConvNullableCharQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.char x)) - let (|ConvNullableDecimalQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.decimal x)) - let (|ConvNullableFloatQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.float x)) - let (|ConvNullableDoubleQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.double x)) - let (|ConvNullableFloat32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.float32 x)) - let (|ConvNullableSingleQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.single x)) - let (|ConvNullableSByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.sbyte x)) - let (|ConvNullableInt8Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int8 x)) - let (|ConvNullableInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int16 x)) - let (|ConvNullableInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int32 x)) - let (|ConvNullableIntQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int x)) - let (|ConvNullableInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int64 x)) - let (|ConvNullableByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.byte x)) - let (|ConvNullableUInt8Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint8 x)) - let (|ConvNullableUInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint16 x)) - let (|ConvNullableUInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint32 x)) - let (|ConvNullableUInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint64 x)) + let (|GenericEqualityQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> LanguagePrimitives.GenericEquality x y)) + let (|EqualsQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x = y)) + let (|GreaterQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x > y)) + let (|GreaterEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x >= y)) + let (|LessQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x < y)) + let (|LessEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x <= y)) + let (|NotEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x <> y)) + + let (|StaticEqualsQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int, y:int) -> NonStructuralComparison.(=) x y)) + let (|StaticGreaterQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int, y:int) -> NonStructuralComparison.(>) x y)) + let (|StaticGreaterEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int, y:int) -> NonStructuralComparison.(>=) x y)) + let (|StaticLessQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int, y:int) -> NonStructuralComparison.(<) x y)) + let (|StaticLessEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int, y:int) -> NonStructuralComparison.(<=) x y)) + let (|StaticNotEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int, y:int) -> NonStructuralComparison.(<>) x y)) + + let (|NullableEqualsQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?= ) x y)) + let (|NullableNotEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?<> ) x y)) + let (|NullableGreaterQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?> ) x y)) + let (|NullableGreaterEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?>= ) x y)) + let (|NullableLessQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?< ) x y)) + let (|NullableLessEqQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?<= ) x y)) + + let (|NullableEqualsNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?=? ) x y)) + let (|NullableNotEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?<>? ) x y)) + let (|NullableGreaterNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?>? ) x y)) + let (|NullableGreaterEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?>=? ) x y)) + let (|NullableLessNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ? NullableOperators.( ?<=? ) x y)) + + let (|EqualsNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( =? ) x y)) + let (|NotEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( <>? ) x y)) + let (|GreaterNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( >? ) x y)) + let (|GreaterEqNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( >=? ) x y)) + let (|LessNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( NullableOperators.( <=? ) x y)) + + let (|MakeDecimalQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (a1, a2, a3, a4, a5) -> LanguagePrimitives.IntrinsicFunctions.MakeDecimal a1 a2 a3 a4 a5)) + + let (|NullablePlusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?+ ) x y)) + let (|NullablePlusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?+? ) x y)) + let (|PlusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( +? ) x y)) + + let (|NullableMinusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?- ) x y)) + let (|NullableMinusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?-? ) x y)) + let (|MinusNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( -? ) x y)) + + let (|NullableMultiplyQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?* ) x y)) + let (|NullableMultiplyNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?*? ) x y)) + let (|MultiplyNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( *? ) x y)) + + let (|NullableDivideQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?/ ) x y)) + let (|NullableDivideNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?/? ) x y)) + let (|DivideNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( /? ) x y)) + + let (|NullableModuloQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?% ) x y)) + let (|NullableModuloNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( ?%? ) x y)) + let (|ModuloNullableQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> NullableOperators.( %? ) x y)) + + let (|NotQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> not x)) + let (|NegQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x:int) -> -x)) + let (|PlusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x + y)) + let (|DivideQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x / y)) + let (|MinusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x - y)) + let (|MultiplyQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x * y)) + let (|ModuloQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x % y)) + let (|ShiftLeftQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x <<< y)) + let (|ShiftRightQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x >>> y)) + let (|BitwiseAndQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x &&& y)) + let (|BitwiseOrQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x ||| y)) + let (|BitwiseXorQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> x ^^^ y)) + let (|BitwiseNotQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> ~~~ x)) + let (|CheckedNeg|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Checked.( ~-) x)) + let (|CheckedPlusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> Checked.( + ) x y)) + let (|CheckedMinusQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> Checked.( - ) x y)) + let (|CheckedMultiplyQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> Checked.( * ) x y)) + + let (|ConvCharQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.char x)) + let (|ConvDecimalQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.decimal x)) + let (|ConvFloatQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.float x)) + let (|ConvFloat32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.float32 x)) + let (|ConvSByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.sbyte x)) + + let (|ConvInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int16 x)) + let (|ConvInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int32 x)) + let (|ConvIntQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int x)) + let (|ConvInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.int64 x)) + let (|ConvByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.byte x)) + let (|ConvUInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.uint16 x)) + let (|ConvUInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.uint32 x)) + let (|ConvUInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Operators.uint64 x)) + + let (|ConvInt8Q|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToSByte")) + let (|ConvUInt8Q|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToByte")) + let (|ConvDoubleQ|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToDouble")) + let (|ConvSingleQ|_|) = SpecificCallToMethodInfo (typeof.Assembly.GetType("Microsoft.FSharp.Core.ExtraTopLevelOperators").GetMethod("ToSingle")) + + let (|ConvNullableCharQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.char x)) + let (|ConvNullableDecimalQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.decimal x)) + let (|ConvNullableFloatQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.float x)) + let (|ConvNullableDoubleQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.double x)) + let (|ConvNullableFloat32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.float32 x)) + let (|ConvNullableSingleQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.single x)) + let (|ConvNullableSByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.sbyte x)) + let (|ConvNullableInt8Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int8 x)) + let (|ConvNullableInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int16 x)) + let (|ConvNullableInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int32 x)) + let (|ConvNullableIntQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int x)) + let (|ConvNullableInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.int64 x)) + let (|ConvNullableByteQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.byte x)) + let (|ConvNullableUInt8Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint8 x)) + let (|ConvNullableUInt16Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint16 x)) + let (|ConvNullableUInt32Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint32 x)) + let (|ConvNullableUInt64Q|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.uint64 x)) // LINQ expressions can't do native integer operations, so we don't convert these - //let (|ConvNullableIntPtrQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.nativeint x)) - //let (|ConvNullableUIntPtrQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.unativeint x)) + //let (|ConvNullableIntPtrQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.nativeint x)) + //let (|ConvNullableUIntPtrQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> Nullable.unativeint x)) let (|UnboxGeneric|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> LanguagePrimitives.IntrinsicFunctions.UnboxGeneric x)) @@ -375,313 +383,319 @@ module LeafExpressionConverter = let (|ImplicitExpressionConversionHelperQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> ImplicitExpressionConversionHelper x)) let (|MemberInitializationHelperQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> MemberInitializationHelper x)) let (|NewAnonymousObjectHelperQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun x -> NewAnonymousObjectHelper x)) - let (|ArrayLookupQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x,y) -> LanguagePrimitives.IntrinsicFunctions.GetArray x y)) + let (|ArrayLookupQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (x, y) -> LanguagePrimitives.IntrinsicFunctions.GetArray x y)) + //let (|ArrayAssignQ|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun -> LanguagePrimitives.IntrinsicFunctions.SetArray : int[] -> int -> int -> unit)) - //let (|ArrayTypeQ|_|) (ty:System.Type) = if ty.IsArray && ty.GetArrayRank() = 1 then Some(ty.GetElementType()) else None - let substHelperMeth = - methodhandleof (fun (x:Expr,y:Var[],z:obj[]) -> SubstHelper (x,y,z)) - |> System.Reflection.MethodInfo.GetMethodFromHandle + //let (|ArrayTypeQ|_|) (ty:System.Type) = if ty.IsArray && ty.GetArrayRank() = 1 then Some (ty.GetElementType()) else None + let substHelperMeth = + methodhandleof (fun (x:Expr, y:Var[], z:obj[]) -> SubstHelper (x, y, z)) + |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo - let substHelperRawMeth = - methodhandleof (fun (x:Expr,y:Var[],z:obj[]) -> SubstHelperRaw (x,y,z)) - |> System.Reflection.MethodInfo.GetMethodFromHandle + let substHelperRawMeth = + methodhandleof (fun (x:Expr, y:Var[], z:obj[]) -> SubstHelperRaw (x, y, z)) + |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo let (-->) ty1 ty2 = Reflection.FSharpType.MakeFunctionType(ty1, ty2) /// Extract member initialization expression stored in 'MemberInitializationHelper' (by QueryExtensions.fs) let rec (|Sequentials|) = function - | Patterns.Sequential(a,Sequentials (b,c)) -> (a :: b, c) + | Patterns.Sequential(a, Sequentials (b, c)) -> (a :: b, c) | a -> [], a let (|MemberInitializationQ|_|) = function - | MemberInitializationHelperQ (None, _, [ Sequentials (propSets, init) ]) -> Some(init, propSets) + | MemberInitializationHelperQ (None, _, [ Sequentials (propSets, init) ]) -> Some (init, propSets) | _ -> None - + /// Extract construction of anonymous object noted by use of in 'NewAnonymousObjectHelper' (by QueryExtensions.fs) let (|NewAnonymousObjectQ|_|) = function - | NewAnonymousObjectHelperQ (None, _, [ Patterns.NewObject(ctor,args) ]) -> Some(ctor,args) + | NewAnonymousObjectHelperQ (None, _, [ Patterns.NewObject(ctor, args) ]) -> Some (ctor, args) | _ -> None - - /// Extract nullable constructions + + /// Extract nullable constructions let (|NullableConstruction|_|) = function - | NewObject(c,[arg]) when equivHeadTypes c.DeclaringType (typeof>) -> Some arg + | NewObject(c, [arg]) when equivHeadTypes c.DeclaringType (typeof>) -> Some arg | _ -> None - + /// Convert F# quotations to LINQ expression trees. /// A more polished LINQ-Quotation translator will be published /// concert with later versions of LINQ. - let rec ConvExprToLinqInContext (env:ConvEnv) (inp:Expr) = + let rec ConvExprToLinqInContext (env:ConvEnv) (inp:Expr) = //printf "ConvExprToLinqInContext : %A\n" inp - match inp with - - // Generic cases - | Patterns.Var v -> - try - Map.find v env.varEnv - with - | :? KeyNotFoundException -> invalidOp ("The variable '"+ v.Name + "' was not found in the translation context'") - - | DerivedPatterns.AndAlso(x1, x2) -> Expression.AndAlso(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | DerivedPatterns.OrElse(x1, x2) -> Expression.OrElse(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | Patterns.Value(x, ty) -> Expression.Constant(x, ty) |> asExpr - - | UnboxGeneric(_, [toTy], [x]) - | Patterns.Coerce(x, toTy) -> - let converted = ConvExprToLinqInContext env x - + match inp with + + // Generic cases + | Patterns.Var v -> + try + Map.find v env.varEnv + with + | :? KeyNotFoundException -> invalidOp ("The variable '"+ v.Name + "' was not found in the translation context'") + + | DerivedPatterns.AndAlso(x1, x2) -> + Expression.AndAlso(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + + | DerivedPatterns.OrElse(x1, x2) -> + Expression.OrElse(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + + | Patterns.Value(x, ty) -> + Expression.Constant(x, ty) |> asExpr + + | UnboxGeneric(_, [toTy], [x]) + | Patterns.Coerce(x, toTy) -> + let converted = ConvExprToLinqInContext env x + // Most of conversion scenarios in C# are covered by Expression.Convert if x.Type.Equals toTy then converted // source and target types match - do nothing elif not (x.Type.IsValueType || toTy.IsValueType) && toTy.IsAssignableFrom x.Type then converted // converting reference type to supertype - do nothing else Expression.Convert(converted, toTy) |> asExpr // emit Expression.Convert - | Patterns.TypeTest(x, toTy) -> + | Patterns.TypeTest(x, toTy) -> Expression.TypeIs(ConvExprToLinqInContext env x, toTy) |> asExpr - + | TypeTestGeneric(_, [toTy], [x]) -> Expression.TypeIs(ConvExprToLinqInContext env x, toTy) |> asExpr - + // Expr.*Get - | Patterns.FieldGet(objOpt, fieldInfo) -> + | Patterns.FieldGet(objOpt, fieldInfo) -> Expression.Field(ConvObjArg env objOpt None, fieldInfo) |> asExpr - | Patterns.TupleGet(arg, n) -> - let argP = ConvExprToLinqInContext env arg - let rec build ty argP n = - match Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, n) with - | propInfo, None -> - Expression.Property(argP, propInfo) |> asExpr - | propInfo, Some(nestedTy, n2) -> + | Patterns.TupleGet(arg, n) -> + let argP = ConvExprToLinqInContext env arg + let rec build ty argP n = + match Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, n) with + | propInfo, None -> + Expression.Property(argP, propInfo) |> asExpr + | propInfo, Some (nestedTy, n2) -> build nestedTy (Expression.Property(argP, propInfo) |> asExpr) n2 build arg.Type argP n - - | Patterns.PropertyGet(objOpt, propInfo, args) -> - let coerceTo = - if objOpt.IsSome && FSharpType.IsUnion propInfo.DeclaringType && FSharpType.IsUnion propInfo.DeclaringType.BaseType then + + | Patterns.PropertyGet(objOpt, propInfo, args) -> + let coerceTo = + if objOpt.IsSome && FSharpType.IsUnion propInfo.DeclaringType && FSharpType.IsUnion propInfo.DeclaringType.BaseType then Some propInfo.DeclaringType - else + else None - match args with - | [] -> + match args with + | [] -> Expression.Property(ConvObjArg env objOpt coerceTo, propInfo) |> asExpr - | _ -> + | _ -> let argsP = ConvExprsToLinq env args Expression.Call(ConvObjArg env objOpt coerceTo, propInfo.GetGetMethod(true), argsP) |> asExpr // Expr.(Call, Application) - | Patterns.Call(objOpt, minfo, args) -> + | Patterns.Call(objOpt, minfo, args) -> - match inp with + match inp with // Special cases for this translation // Object initialization generated by LinqQueries | MemberInitializationQ(ctor, propInfos) -> let bindings = [| for p in propInfos -> - match p with + match p with | Patterns.PropertySet(_, pinfo, args, assign) -> if args <> [] then raise (NotSupportedException "Parameterized properties not supported in member initialization.") Expression.Bind(pinfo, ConvExprToLinqInContext env assign) :> MemberBinding - | _ -> + | _ -> raise (NotSupportedException "Expected PropertySet in member initialization") |] match ConvExprToLinqInContext env ctor with | :? NewExpression as converted -> Expression.MemberInit(converted, bindings) |> asExpr - | _ -> raise (NotSupportedException "Expected Constructor call in member initialization") - + | _ -> raise (NotSupportedException "Expected Constructor call in member initialization") + // Anonymous type initialization generated by LinqQueries | NewAnonymousObjectQ(ctor, args) -> - let argsR = ConvExprsToLinq env args + let argsR = ConvExprsToLinq env args let props = ctor.DeclaringType.GetProperties() Expression.New(ctor, argsR, [| for p in props -> (p :> MemberInfo) |]) |> asExpr - - - // Do the same thing as C# compiler for string addition - | PlusQ (_, [ty1;ty2;ty3],[x1;x2]) when (ty1 = typeof) && (ty2 = typeof) && (ty3 = typeof) -> + + + // Do the same thing as C# compiler for string addition + | PlusQ (_, [ty1; ty2; ty3], [x1; x2]) when (ty1 = typeof) && (ty2 = typeof) && (ty3 = typeof) -> Expression.Add(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2, StringConcat) |> asExpr - | GenericEqualityQ (_, _,[x1;x2]) - | EqualsQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Equal - | NotEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.NotEqual - | GreaterQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.GreaterThan - | GreaterEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.GreaterThanOrEqual - | LessQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.LessThan - | LessEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.LessThanOrEqual - | NotQ (_, _, [x1]) -> Expression.Not(ConvExprToLinqInContext env x1) |> asExpr - - | StaticEqualsQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Equal - | StaticNotEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.NotEqual - | StaticGreaterQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.GreaterThan - | StaticGreaterEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.GreaterThanOrEqual - | StaticLessQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.LessThan - | StaticLessEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.LessThanOrEqual - - | NullableEqualsQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.Equal - | NullableNotEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.NotEqual - | NullableGreaterQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.GreaterThan - | NullableGreaterEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.GreaterThanOrEqual - | NullableLessQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.LessThan - | NullableLessEqQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.LessThanOrEqual - - | EqualsNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.Equal - | NotEqNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.NotEqual - | GreaterNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.GreaterThan - | GreaterEqNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.GreaterThanOrEqual - | LessNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.LessThan - | LessEqNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.LessThanOrEqual - - | NullableEqualsNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Equal - | NullableNotEqNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.NotEqual - | NullableGreaterNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.GreaterThan - | NullableGreaterEqNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.GreaterThanOrEqual - | NullableLessNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.LessThan - | NullableLessEqNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.LessThanOrEqual - + | GenericEqualityQ (_, _, [x1; x2]) + | EqualsQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Equal + | NotEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.NotEqual + | GreaterQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.GreaterThan + | GreaterEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.GreaterThanOrEqual + | LessQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.LessThan + | LessEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.LessThanOrEqual + | NotQ (_, _, [x1]) -> Expression.Not(ConvExprToLinqInContext env x1) |> asExpr + + | StaticEqualsQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Equal + | StaticNotEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.NotEqual + | StaticGreaterQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.GreaterThan + | StaticGreaterEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.GreaterThanOrEqual + | StaticLessQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.LessThan + | StaticLessEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.LessThanOrEqual + + | NullableEqualsQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.Equal + | NullableNotEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.NotEqual + | NullableGreaterQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.GreaterThan + | NullableGreaterEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.GreaterThanOrEqual + | NullableLessQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.LessThan + | NullableLessEqQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.LessThanOrEqual + + | EqualsNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.Equal + | NotEqNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.NotEqual + | GreaterNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.GreaterThan + | GreaterEqNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.GreaterThanOrEqual + | LessNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.LessThan + | LessEqNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.LessThanOrEqual + + | NullableEqualsNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Equal + | NullableNotEqNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.NotEqual + | NullableGreaterNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.GreaterThan + | NullableGreaterEqNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.GreaterThanOrEqual + | NullableLessNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.LessThan + | NullableLessEqNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.LessThanOrEqual + // Detect the F# quotation encoding of decimal literals - | MakeDecimalQ (_, _, [Int32 lo; Int32 med; Int32 hi; Bool isNegative; Byte scale]) -> - Expression.Constant(new System.Decimal(lo,med,hi,isNegative,scale)) |> asExpr - - | NegQ (_, _, [x1]) -> Expression.Negate(ConvExprToLinqInContext env x1) |> asExpr - | PlusQ (_, _,[x1;x2]) -> Expression.Add(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | DivideQ (_, _,[x1;x2]) -> Expression.Divide (ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | MinusQ (_, _,[x1;x2]) -> Expression.Subtract(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | MultiplyQ (_, _,[x1;x2]) -> Expression.Multiply(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | ModuloQ (_, _,[x1;x2]) -> Expression.Modulo (ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - - | ShiftLeftQ (_, _,[x1;x2]) -> Expression.LeftShift(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | ShiftRightQ (_, _,[x1;x2]) -> Expression.RightShift(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | BitwiseAndQ (_, _,[x1;x2]) -> Expression.And(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | BitwiseOrQ (_, _,[x1;x2]) -> Expression.Or(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | BitwiseXorQ (_, _,[x1;x2]) -> Expression.ExclusiveOr(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | MakeDecimalQ (_, _, [Int32 lo; Int32 med; Int32 hi; Bool isNegative; Byte scale]) -> + Expression.Constant (new System.Decimal(lo, med, hi, isNegative, scale)) |> asExpr + + | NegQ (_, _, [x1]) -> Expression.Negate(ConvExprToLinqInContext env x1) |> asExpr + | PlusQ (_, _, [x1; x2]) -> Expression.Add(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | DivideQ (_, _, [x1; x2]) -> Expression.Divide (ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | MinusQ (_, _, [x1; x2]) -> Expression.Subtract(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | MultiplyQ (_, _, [x1; x2]) -> Expression.Multiply(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | ModuloQ (_, _, [x1; x2]) -> Expression.Modulo (ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + + | ShiftLeftQ (_, _, [x1; x2]) -> Expression.LeftShift(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | ShiftRightQ (_, _, [x1; x2]) -> Expression.RightShift(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | BitwiseAndQ (_, _, [x1; x2]) -> Expression.And(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | BitwiseOrQ (_, _, [x1; x2]) -> Expression.Or(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | BitwiseXorQ (_, _, [x1; x2]) -> Expression.ExclusiveOr(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr | BitwiseNotQ (_, _, [x1]) -> Expression.Not(ConvExprToLinqInContext env x1) |> asExpr - | CheckedNeg (_, _, [x1]) -> Expression.NegateChecked(ConvExprToLinqInContext env x1) |> asExpr - | CheckedPlusQ (_, _,[x1;x2]) -> Expression.AddChecked(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | CheckedMinusQ (_, _,[x1;x2]) -> Expression.SubtractChecked(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - | CheckedMultiplyQ (_, _,[x1;x2]) -> Expression.MultiplyChecked(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr - - - | NullablePlusQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.Add - | PlusNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.Add - | NullablePlusNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Add - - | NullableMinusQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.Subtract - | MinusNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.Subtract - | NullableMinusNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Subtract - - | NullableMultiplyQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.Multiply - | MultiplyNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.Multiply - | NullableMultiplyNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Multiply - - | NullableDivideQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.Divide - | DivideNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.Divide - | NullableDivideNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Divide - - | NullableModuloQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 true Expression.Modulo - | ModuloNullableQ (_, _,[x1;x2]) -> transBinOp env true x1 x2 false Expression.Modulo - | NullableModuloNullableQ (_, _,[x1;x2]) -> transBinOp env false x1 x2 false Expression.Modulo - - | ConvNullableCharQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | CheckedNeg (_, _, [x1]) -> Expression.NegateChecked(ConvExprToLinqInContext env x1) |> asExpr + | CheckedPlusQ (_, _, [x1; x2]) -> Expression.AddChecked(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | CheckedMinusQ (_, _, [x1; x2]) -> Expression.SubtractChecked(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + | CheckedMultiplyQ (_, _, [x1; x2]) -> Expression.MultiplyChecked(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr + + + | NullablePlusQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.Add + | PlusNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.Add + | NullablePlusNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Add + + | NullableMinusQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.Subtract + | MinusNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.Subtract + | NullableMinusNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Subtract + + | NullableMultiplyQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.Multiply + | MultiplyNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.Multiply + | NullableMultiplyNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Multiply + + | NullableDivideQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.Divide + | DivideNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.Divide + | NullableDivideNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Divide + + | NullableModuloQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 true Expression.Modulo + | ModuloNullableQ (_, _, [x1; x2]) -> transBinOp env true x1 x2 false Expression.Modulo + | NullableModuloNullableQ (_, _, [x1; x2]) -> transBinOp env false x1 x2 false Expression.Modulo + + | ConvNullableCharQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr | ConvNullableDecimalQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableFloatQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableDoubleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableFloatQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableDoubleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr | ConvNullableFloat32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableSingleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableSByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableIntQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableUInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableUInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableUInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvNullableUInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableSingleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableSByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableIntQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableUInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableUInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableUInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + | ConvNullableUInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr // LINQ expressions can't do native integer operations, so we don't convert these - //| ConvNullableIntPtrQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - //| ConvNullableUIntPtrQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + //| ConvNullableIntPtrQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr + //| ConvNullableUIntPtrQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof>) |> asExpr - | ConvCharQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvCharQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr | ConvDecimalQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvFloatQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvDoubleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvFloatQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvDoubleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr | ConvFloat32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvSingleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvSByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvIntQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvUInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvUInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvUInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ConvUInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr - - | CheckedConvCharQ (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | CheckedConvSByteQ (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | CheckedConvInt8Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | CheckedConvInt16Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | CheckedConvInt32Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | CheckedConvInt64Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | CheckedConvByteQ (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvSingleQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvSByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvIntQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvByteQ (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvUInt8Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvUInt16Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvUInt32Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + | ConvUInt64Q (_, _, [x1]) -> Expression.Convert(ConvExprToLinqInContext env x1, typeof) |> asExpr + + | CheckedConvCharQ (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | CheckedConvSByteQ (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | CheckedConvInt8Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | CheckedConvInt16Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | CheckedConvInt32Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | CheckedConvInt64Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr + | CheckedConvByteQ (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr | CheckedConvUInt8Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr | CheckedConvUInt16Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr | CheckedConvUInt32Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr | CheckedConvUInt64Q (_, _, [x1]) -> Expression.ConvertChecked(ConvExprToLinqInContext env x1, typeof) |> asExpr - | ArrayLookupQ (_, [_;_;_],[x1;x2]) -> + | ArrayLookupQ (_, [_; _; _], [x1; x2]) -> Expression.ArrayIndex(ConvExprToLinqInContext env x1, ConvExprToLinqInContext env x2) |> asExpr // Throw away markers inserted to satisfy C#'s design where they pass an argument // or type T to an argument expecting Expression. | ImplicitExpressionConversionHelperQ (_, [_], [x1]) -> ConvExprToLinqInContext env x1 - - | _ -> - let argsP = ConvExprsToLinq env args - Expression.Call(ConvObjArg env objOpt None, minfo, argsP) |> asExpr + + | _ -> + let argsP = ConvExprsToLinq env args + Expression.Call(ConvObjArg env objOpt None, minfo, argsP) |> asExpr #if !NO_CURRIED_FUNCTION_OPTIMIZATIONS // f x1 x2 x3 x4 --> InvokeFast4 - | Patterns.Application(Patterns.Application(Patterns.Application(Patterns.Application(f, arg1), arg2), arg3), arg4) -> + | Patterns.Application(Patterns.Application(Patterns.Application(Patterns.Application(f, arg1), arg2), arg3), arg4) -> // TODO: amortize this computation based on f.Type - let meth = + let meth = let domainTy1, rangeTy = getFunctionType f.Type let domainTy2, rangeTy = getFunctionType rangeTy let domainTy3, rangeTy = getFunctionType rangeTy let domainTy4, rangeTy = getFunctionType rangeTy - let ty = domainTy1 --> domainTy2 + let ty = domainTy1 --> domainTy2 (ty.GetMethods() |> Array.find (fun minfo -> minfo.Name = "InvokeFast" && minfo.GetParameters().Length = 5)).MakeGenericMethod [| domainTy3; domainTy4; rangeTy |] - let argsP = ConvExprsToLinq env [f; arg1;arg2;arg3; arg4] + let argsP = ConvExprsToLinq env [f; arg1; arg2; arg3; arg4] Expression.Call((null:Expression), meth, argsP) |> asExpr // f x1 x2 x3 --> InvokeFast3 - | Patterns.Application(Patterns.Application(Patterns.Application(f, arg1), arg2), arg3) -> + | Patterns.Application(Patterns.Application(Patterns.Application(f, arg1), arg2), arg3) -> // TODO: amortize this computation based on f.Type - let meth = + let meth = let domainTy1, rangeTy = getFunctionType f.Type let domainTy2, rangeTy = getFunctionType rangeTy let domainTy3, rangeTy = getFunctionType rangeTy - let ty = domainTy1 --> domainTy2 + let ty = domainTy1 --> domainTy2 (ty.GetMethods() |> Array.find (fun minfo -> minfo.Name = "InvokeFast" && minfo.GetParameters().Length = 4)).MakeGenericMethod [| domainTy3; rangeTy |] - let argsP = ConvExprsToLinq env [f; arg1;arg2;arg3] + let argsP = ConvExprsToLinq env [f; arg1; arg2; arg3] Expression.Call((null:Expression), meth, argsP) |> asExpr // f x1 x2 --> InvokeFast2 - | Patterns.Application(Patterns.Application(f, arg1), arg2) -> + | Patterns.Application(Patterns.Application(f, arg1), arg2) -> // TODO: amortize this computation based on f.Type - let meth = + let meth = let domainTy1, rangeTy = getFunctionType f.Type let domainTy2, rangeTy = getFunctionType rangeTy - let ty = domainTy1 --> domainTy2 + let ty = domainTy1 --> domainTy2 (ty.GetMethods() |> Array.find (fun minfo -> minfo.Name = "InvokeFast" && minfo.GetParameters().Length = 3)).MakeGenericMethod [| rangeTy |] - let argsP = ConvExprsToLinq env [f; arg1;arg2] + let argsP = ConvExprsToLinq env [f; arg1; arg2] Expression.Call((null:Expression), meth, argsP) |> asExpr #endif // f x1 --> Invoke - | Patterns.Application(f, arg) -> + | Patterns.Application(f, arg) -> let fP = ConvExprToLinqInContext env f let argP = ConvExprToLinqInContext env arg // TODO: amortize this computation based on f.Type @@ -689,90 +703,90 @@ module LeafExpressionConverter = Expression.Call(fP, meth, [| argP |]) |> asExpr // Expr.New* - | Patterns.NewRecord(recdTy, args) -> - let ctorInfo = Reflection.FSharpValue.PreComputeRecordConstructorInfo(recdTy, showAll) + | Patterns.NewRecord(recdTy, args) -> + let ctorInfo = Reflection.FSharpValue.PreComputeRecordConstructorInfo(recdTy, showAll) Expression.New(ctorInfo, ConvExprsToLinq env args) |> asExpr - | Patterns.NewArray(ty, args) -> + | Patterns.NewArray(ty, args) -> Expression.NewArrayInit(ty, ConvExprsToLinq env args) |> asExpr - | Patterns.DefaultValue ty -> + | Patterns.DefaultValue ty -> Expression.New ty |> asExpr - | Patterns.NewUnionCase(unionCaseInfo, args) -> + | Patterns.NewUnionCase(unionCaseInfo, args) -> let methInfo = Reflection.FSharpValue.PreComputeUnionConstructorInfo(unionCaseInfo, showAll) - let argsR = ConvExprsToLinq env args + let argsR = ConvExprsToLinq env args Expression.Call((null:Expression), methInfo, argsR) |> asExpr #if !NO_PATTERN_MATCHING_IN_INPUT_LANGUAGE - | Patterns.UnionCaseTest(e, unionCaseInfo) -> + | Patterns.UnionCaseTest(e, unionCaseInfo) -> let methInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo(unionCaseInfo.DeclaringType, showAll) - let obj = ConvExprToLinqInContext env e - let tagE = - match methInfo with - | :? PropertyInfo as p -> + let obj = ConvExprToLinqInContext env e + let tagE = + match methInfo with + | :? PropertyInfo as p -> Expression.Property(obj, p) |> asExpr - | :? MethodInfo as m -> - Expression.Call((null:Expression), m,[| obj |]) |> asExpr + | :? MethodInfo as m -> + Expression.Call((null:Expression), m, [| obj |]) |> asExpr | _ -> failwith "unreachable case" Expression.Equal(tagE, Expression.Constant(unionCaseInfo.Tag)) |> asExpr #endif - | (Patterns.NewObject(ctorInfo, args) as x) -> - match x with + | (Patterns.NewObject(ctorInfo, args) as x) -> + match x with // LINQ providers prefer C# "Nullable x" to be "Convert x", since that's what C# uses // to construct nullable values. | NullableConstruction arg -> Expression.Convert(ConvExprToLinqInContext env arg, x.Type) |> asExpr | _ -> Expression.New(ctorInfo, ConvExprsToLinq env args) |> asExpr - | Patterns.NewDelegate(dty, vs, b) -> - let vsP = List.map ConvVarToLinq vs + | Patterns.NewDelegate(dty, vs, b) -> + let vsP = List.map ConvVarToLinq vs let env = {env with varEnv = List.foldBack2 (fun (v:Var) vP -> Map.add v (vP |> asExpr)) vs vsP env.varEnv } - let bodyP = ConvExprToLinqInContext env b - Expression.Lambda(dty, bodyP, vsP) |> asExpr + let bodyP = ConvExprToLinqInContext env b + Expression.Lambda(dty, bodyP, vsP) |> asExpr - | Patterns.NewTuple args -> + | Patterns.NewTuple args -> let tupTy = args |> List.map (fun arg -> arg.Type) |> Array.ofList |> Reflection.FSharpType.MakeTupleType - let argsP = ConvExprsToLinq env args - let rec build ty (argsP: Expression[]) = - match Reflection.FSharpValue.PreComputeTupleConstructorInfo ty with - | ctorInfo, None -> Expression.New(ctorInfo, argsP) |> asExpr - | ctorInfo, Some(nestedTy) -> + let argsP = ConvExprsToLinq env args + let rec build ty (argsP: Expression[]) = + match Reflection.FSharpValue.PreComputeTupleConstructorInfo ty with + | ctorInfo, None -> Expression.New(ctorInfo, argsP) |> asExpr + | ctorInfo, Some (nestedTy) -> let n = ctorInfo.GetParameters().Length - 1 Expression.New(ctorInfo, Array.append argsP.[0..n-1] [| build nestedTy argsP.[n..] |]) |> asExpr build tupTy argsP - | Patterns.IfThenElse(g, t, e) -> + | Patterns.IfThenElse(g, t, e) -> Expression.Condition(ConvExprToLinqInContext env g, ConvExprToLinqInContext env t, ConvExprToLinqInContext env e) |> asExpr - | Patterns.QuoteTyped x -> + | Patterns.QuoteTyped x -> let fvs = x.GetFreeVars() - - Expression.Call(substHelperMeth.MakeGenericMethod [| x.Type |], - [| (Expression.Constant x) |> asExpr; - (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Constant fv |> asExpr |]) |> asExpr); - (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Convert(env.varEnv.[fv], typeof) |> asExpr |]) |> asExpr) |]) + + Expression.Call(substHelperMeth.MakeGenericMethod [| x.Type |], + [| (Expression.Constant x) |> asExpr + (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Constant fv |> asExpr |]) |> asExpr) + (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Convert(env.varEnv.[fv], typeof) |> asExpr |]) |> asExpr) |]) |> asExpr - - | Patterns.QuoteRaw x -> + + | Patterns.QuoteRaw x -> let fvs = x.GetFreeVars() - - Expression.Call(substHelperRawMeth, - [| (Expression.Constant x) |> asExpr; - (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Constant fv |> asExpr |]) |> asExpr); - (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Convert(env.varEnv.[fv], typeof) |> asExpr |]) |> asExpr) |]) + + Expression.Call(substHelperRawMeth, + [| (Expression.Constant x) |> asExpr + (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Constant fv |> asExpr |]) |> asExpr) + (Expression.NewArrayInit(typeof, [| for fv in fvs -> Expression.Convert(env.varEnv.[fv], typeof) |> asExpr |]) |> asExpr) |]) |> asExpr - - | Patterns.Let (v, e, b) -> + + | Patterns.Let (v, e, b) -> let vP = ConvVarToLinq v - let envinner = { env with varEnv = Map.add v (vP |> asExpr) env.varEnv } - let bodyP = ConvExprToLinqInContext envinner b + let envinner = { env with varEnv = Map.add v (vP |> asExpr) env.varEnv } + let bodyP = ConvExprToLinqInContext envinner b let eP = ConvExprToLinqInContext env e - let ty = Expression.GetFuncType [| v.Type; b.Type |] - let lam = Expression.Lambda(ty, bodyP,[| vP |]) |> asExpr - Expression.Call(lam, ty.GetMethod("Invoke", instanceBindingFlags),[| eP |]) |> asExpr + let ty = Expression.GetFuncType [| v.Type; b.Type |] + let lam = Expression.Lambda(ty, bodyP, [| vP |]) |> asExpr + Expression.Call(lam, ty.GetMethod("Invoke", instanceBindingFlags), [| eP |]) |> asExpr - | Patterns.Lambda(v, body) -> + | Patterns.Lambda(v, body) -> let vP = ConvVarToLinq v let env = { env with varEnv = Map.add v (vP |> asExpr) env.varEnv } let bodyP = ConvExprToLinqInContext env body @@ -785,34 +799,34 @@ module LeafExpressionConverter = typedefof>, tyargs let convType = lambdaTy.MakeGenericType tyargs let convDelegate = Expression.Lambda(convType, bodyP, [| vP |]) |> asExpr - Expression.Call(typeof,"ToFSharpFunc", tyargs,[| convDelegate |]) |> asExpr + Expression.Call(typeof, "ToFSharpFunc", tyargs, [| convDelegate |]) |> asExpr - | _ -> + | _ -> raise (new NotSupportedException(Printf.sprintf "Could not convert the following F# Quotation to a LINQ Expression Tree\n--------\n%A\n-------------\n" inp)) and transBinOp env addConvertLeft x1 x2 addConvertRight (exprErasedConstructor : _ * _ -> _) = let e1 = ConvExprToLinqInContext env x1 let e2 = ConvExprToLinqInContext env x2 - let e1 = if addConvertLeft then Expression.Convert(e1, typedefof>.MakeGenericType [| e1.Type |]) |> asExpr else e1 + let e1 = if addConvertLeft then Expression.Convert(e1, typedefof>.MakeGenericType [| e1.Type |]) |> asExpr else e1 let e2 = if addConvertRight then Expression.Convert(e2, typedefof>.MakeGenericType [| e2.Type |]) |> asExpr else e2 exprErasedConstructor(e1, e2) |> asExpr - and ConvObjArg env objOpt coerceTo : Expression = + and ConvObjArg env objOpt coerceTo : Expression = match objOpt with - | Some obj -> + | Some obj -> let expr = ConvExprToLinqInContext env obj - match coerceTo with + match coerceTo with | None -> expr | Some ty -> Expression.TypeAs(expr, ty) :> Expression - | None -> + | None -> null - and ConvExprsToLinq env es : Expression[] = - es |> List.map (ConvExprToLinqInContext env) |> Array.ofList + and ConvExprsToLinq env es : Expression[] = + es |> List.map (ConvExprToLinqInContext env) |> Array.ofList - and ConvVarToLinq (v: Var) = - //printf "** Expression .Parameter(%a, %a)\n" output_any ty output_any nm; + and ConvVarToLinq (v: Var) = + //printf "** Expression .Parameter(%a, %a)\n" output_any ty output_any nm Expression.Parameter(v.Type, v.Name) let ConvExprToLinq (e: Expr) = ConvExprToLinqInContext { varEnv = Map.empty } e @@ -820,25 +834,25 @@ module LeafExpressionConverter = let QuotationToExpression (e: Microsoft.FSharp.Quotations.Expr) = ConvExprToLinq e let QuotationToLambdaExpression (e: Microsoft.FSharp.Quotations.Expr<'T>) = (ConvExprToLinq e) :?> Expression<'T> - // This contorted compilation is used because LINQ's "Compile" is only allowed on lambda expressions, and LINQ + // This contorted compilation is used because LINQ's "Compile" is only allowed on lambda expressions, and LINQ // provides no other way to evaluate the expression. // // REVIEW: It is possible it is just better to interpret the expression in many common cases, e.g. property-gets, values etc. - let EvaluateQuotation (e: Microsoft.FSharp.Quotations.Expr) : obj = + let EvaluateQuotation (e: Microsoft.FSharp.Quotations.Expr) : obj = #if FX_NO_QUOTATIONS_COMPILE raise (new NotSupportedException()) #else match e with - | Value (obj,_) -> obj - | _ -> + | Value (obj, _) -> obj + | _ -> let ty = e.Type let e = Expr.NewDelegate(Expression.GetFuncType([|typeof; ty |]), [new Var("unit", typeof)], e) let linqExpr = (ConvExprToLinq e:?> LambdaExpression) let d = linqExpr.Compile() - try + try d.DynamicInvoke [| box () |] - with :? System.Reflection.TargetInvocationException as exn -> + with :? System.Reflection.TargetInvocationException as exn -> raise exn.InnerException #endif - + diff --git a/src/fsharp/FSharp.Core/Query.fs b/src/fsharp/FSharp.Core/Query.fs index 0f889072c7c..7a4f9b2f5a9 100644 --- a/src/fsharp/FSharp.Core/Query.fs +++ b/src/fsharp/FSharp.Core/Query.fs @@ -17,214 +17,266 @@ open Microsoft.FSharp.Linq.RuntimeHelpers #nowarn "64" [] -type QuerySource<'T, 'Q> (source: seq<'T>) = +type QuerySource<'T, 'Q> (source: seq<'T>) = member __.Source = source [] module Helpers = - + // This helps the somewhat complicated type inference for AverageByNullable and SumByNullable, by making both type in a '+' the same let inline plus (x:'T) (y:'T) = Checked.(+) x y - let inline checkNonNull argName arg = - match box arg with - | null -> nullArg argName + let inline checkNonNull argName arg = + match box arg with + | null -> nullArg argName | _ -> () - let checkThenBySource (source: seq<'T>) = - match source with + let checkThenBySource (source: seq<'T>) = + match source with | :? System.Linq.IOrderedEnumerable<'T> as source -> source | _ -> invalidArg "source" (SR.GetString(SR.thenByError)) - // used so we can define the implementation of QueryBuilder before the Query module (so in Query we can safely use methodhandleof) -module ForwardDeclarations = - type IQueryMethods = - abstract Execute : Expr<'T> -> 'U - abstract EliminateNestedQueries : Expr -> Expr - let mutable Query = +module ForwardDeclarations = + type IQueryMethods = + abstract Execute: Expr<'T> -> 'U + abstract EliminateNestedQueries: Expr -> Expr + + let mutable Query = { new IQueryMethods with member this.Execute(_) = failwith "IQueryMethods.Execute should never be called" member this.EliminateNestedQueries(_) = failwith "IQueryMethods.EliminateNestedQueries should never be called" } - + type QueryBuilder() = - member __.For (source:QuerySource<'T,'Q>, body: 'T -> QuerySource<'Result,'Q2>) : QuerySource<'Result,'Q> = QuerySource (Seq.collect (fun x -> (body x).Source) source.Source) - member __.Zero () = QuerySource Seq.empty - member __.Yield value = QuerySource (Seq.singleton value) - member __.YieldFrom (computation: QuerySource<'T,'Q>) : QuerySource<'T,'Q> = computation - member __.Quote (q:Quotations.Expr<'T>) = q - member __.Source (source: IQueryable<'T>) = QuerySource source - member __.Source (source: IEnumerable<'T>) : QuerySource<'T,System.Collections.IEnumerable> = QuerySource source - - member __.Contains(source:QuerySource<'T,'Q>,key) = Enumerable.Contains(source.Source, key) - member __.Select(source:QuerySource<'T,'Q>,projection) : QuerySource<'U,'Q>= QuerySource (Seq.map projection source.Source) - member __.Where(source:QuerySource<'T,'Q>,predicate) : QuerySource<'T,'Q> = QuerySource (Enumerable.Where (source.Source, Func<_,_>(predicate)) ) - member __.Last (source:QuerySource<'T,'Q>) = Enumerable.Last source.Source - member __.LastOrDefault (source:QuerySource<'T,'Q>) = Enumerable.LastOrDefault source.Source - member __.ExactlyOne (source:QuerySource<'T,'Q>) = Enumerable.Single source.Source - member __.ExactlyOneOrDefault (source:QuerySource<'T,'Q>) = Enumerable.SingleOrDefault source.Source - member __.Count (source:QuerySource<'T,'Q>) = Enumerable.Count source.Source - member __.Distinct (source : QuerySource<'T,'Q> when 'T : equality) : QuerySource<'T,'Q> = QuerySource (Enumerable.Distinct source.Source) - member __.Exists(source: QuerySource<'T,'Q>,predicate) = Enumerable.Any (source.Source, Func<_,_>(predicate)) - member __.All (source: QuerySource<'T,'Q>,predicate) = Enumerable.All (source.Source, Func<_,_>(predicate)) - member __.Head (source: QuerySource<'T,'Q>) = Enumerable.First source.Source - member __.Nth (source: QuerySource<'T,'Q>, index) = Enumerable.ElementAt (source.Source, index) - //let reduceBy projection reduction source = source |> Seq.map projection |> Seq.reduce reduction - member __.Skip (source: QuerySource<'T,'Q>,count) : QuerySource<'T,'Q> = QuerySource (Enumerable.Skip (source.Source, count)) - member __.SkipWhile (source: QuerySource<'T,'Q>,predicate) : QuerySource<'T,'Q> = QuerySource (Enumerable.SkipWhile (source.Source, Func<_,_>(predicate))) - member __.Take (source: QuerySource<'T,'Q>,count) : QuerySource<'T,'Q> = QuerySource (Enumerable.Take (source.Source, count)) - member __.TakeWhile (source: QuerySource<'T,'Q>,predicate) : QuerySource<'T,'Q> = QuerySource (Enumerable.TakeWhile (source.Source, Func<_,_>(predicate))) - member __.Find (source: QuerySource<'T,'Q>,predicate) = Enumerable.First (source.Source, Func<_,_>(predicate)) - member __.HeadOrDefault (source:QuerySource<'T,'Q>) = Enumerable.FirstOrDefault source.Source - - member __.MinBy<'T,'Q,'Key when 'Key : equality and 'Key : comparison> (source:QuerySource<'T,'Q>, valueSelector : 'T -> 'Key) = - Enumerable.Min(source.Source, Func<'T,'Key>(valueSelector)) - - member __.MaxBy<'T,'Q,'Key when 'Key : equality and 'Key : comparison> (source:QuerySource<'T,'Q>, valueSelector : 'T -> 'Key) = - Enumerable.Max(source.Source, Func<'T,'Key>(valueSelector)) - - member __.MinByNullable<'T,'Q,'Key when 'Key : equality and 'Key : comparison and 'Key : (new : unit -> 'Key) and 'Key : struct and 'Key :> ValueType> (source:QuerySource<'T,'Q>, valueSelector : 'T -> Nullable<'Key>) = + member __.For (source:QuerySource<'T, 'Q>, body: 'T -> QuerySource<'Result, 'Q2>) : QuerySource<'Result, 'Q> = + QuerySource (Seq.collect (fun x -> (body x).Source) source.Source) + + member __.Zero () = + QuerySource Seq.empty + + member __.Yield value = + QuerySource (Seq.singleton value) + + member __.YieldFrom (computation: QuerySource<'T, 'Q>) : QuerySource<'T, 'Q> = + computation + + // Indicates to the F# compiler that an implicit quotation is added to use of 'query' + member __.Quote (quotation:Quotations.Expr<'T>) = + quotation + + member __.Source (source: IQueryable<'T>) = + QuerySource source + + member __.Source (source: IEnumerable<'T>) : QuerySource<'T, System.Collections.IEnumerable> = + QuerySource source + + member __.Contains (source:QuerySource<'T, 'Q>, key) = + Enumerable.Contains(source.Source, key) + + member __.Select (source:QuerySource<'T, 'Q>, projection) : QuerySource<'U, 'Q> = + QuerySource (Seq.map projection source.Source) + + member __.Where (source:QuerySource<'T, 'Q>, predicate) : QuerySource<'T, 'Q> = + QuerySource (Enumerable.Where (source.Source, Func<_, _>(predicate)) ) + + member __.Last (source:QuerySource<'T, 'Q>) = + Enumerable.Last source.Source + + member __.LastOrDefault (source:QuerySource<'T, 'Q>) = + Enumerable.LastOrDefault source.Source + + member __.ExactlyOne (source:QuerySource<'T, 'Q>) = + Enumerable.Single source.Source + + member __.ExactlyOneOrDefault (source:QuerySource<'T, 'Q>) = + Enumerable.SingleOrDefault source.Source + + member __.Count (source:QuerySource<'T, 'Q>) = + Enumerable.Count source.Source + + member __.Distinct (source: QuerySource<'T, 'Q> when 'T : equality) : QuerySource<'T, 'Q> = + QuerySource (Enumerable.Distinct source.Source) + + member __.Exists(source: QuerySource<'T, 'Q>, predicate) = + Enumerable.Any (source.Source, Func<_, _>(predicate)) + + member __.All (source: QuerySource<'T, 'Q>, predicate) = + Enumerable.All (source.Source, Func<_, _>(predicate)) + + member __.Head (source: QuerySource<'T, 'Q>) = + Enumerable.First source.Source + + member __.Nth (source: QuerySource<'T, 'Q>, index) = + Enumerable.ElementAt (source.Source, index) + + member __.Skip (source: QuerySource<'T, 'Q>, count) : QuerySource<'T, 'Q> = + QuerySource (Enumerable.Skip (source.Source, count)) + + member __.SkipWhile (source: QuerySource<'T, 'Q>, predicate) : QuerySource<'T, 'Q> = + QuerySource (Enumerable.SkipWhile (source.Source, Func<_, _>(predicate))) + + member __.Take (source: QuerySource<'T, 'Q>, count) : QuerySource<'T, 'Q> = + QuerySource (Enumerable.Take (source.Source, count)) + + member __.TakeWhile (source: QuerySource<'T, 'Q>, predicate) : QuerySource<'T, 'Q> = + QuerySource (Enumerable.TakeWhile (source.Source, Func<_, _>(predicate))) + + member __.Find (source: QuerySource<'T, 'Q>, predicate) = + Enumerable.First (source.Source, Func<_, _>(predicate)) + + member __.HeadOrDefault (source:QuerySource<'T, 'Q>) = + Enumerable.FirstOrDefault source.Source + + member __.MinBy<'T, 'Q, 'Key when 'Key: equality and 'Key: comparison> (source:QuerySource<'T, 'Q>, valueSelector: 'T -> 'Key) = + Enumerable.Min(source.Source, Func<'T, 'Key>(valueSelector)) + + member __.MaxBy<'T, 'Q, 'Key when 'Key: equality and 'Key: comparison> (source:QuerySource<'T, 'Q>, valueSelector: 'T -> 'Key) = + Enumerable.Max(source.Source, Func<'T, 'Key>(valueSelector)) + + member __.MinByNullable<'T, 'Q, 'Key when 'Key: equality and 'Key: comparison and 'Key: (new: unit -> 'Key) and 'Key: struct and 'Key:> ValueType> (source:QuerySource<'T, 'Q>, valueSelector: 'T -> Nullable<'Key>) = Enumerable.Min(source.Source, Func<'T, Nullable<'Key>>(valueSelector)) - member __.MaxByNullable<'T,'Q,'Key when 'Key : equality and 'Key : comparison and 'Key : (new : unit -> 'Key) and 'Key : struct and 'Key :> ValueType> (source:QuerySource<'T,'Q>, valueSelector : 'T -> Nullable<'Key>) = + member __.MaxByNullable<'T, 'Q, 'Key when 'Key: equality and 'Key: comparison and 'Key: (new: unit -> 'Key) and 'Key: struct and 'Key:> ValueType> (source:QuerySource<'T, 'Q>, valueSelector: 'T -> Nullable<'Key>) = Enumerable.Max(source.Source, Func<'T, Nullable<'Key>>(valueSelector)) member inline __.SumByNullable<'T, 'Q, ^Value when ^Value :> ValueType - and ^Value : struct - and ^Value : (new : unit -> ^Value) - and ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) + and ^Value : struct + and ^Value : (new : unit -> ^Value) + and ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) and ^Value : (static member Zero : ^Value) and default ^Value : int> - (source: QuerySource<'T,'Q>, valueSelector : 'T -> Nullable< ^Value >) : Nullable< ^Value > = + (source: QuerySource<'T, 'Q>, valueSelector : 'T -> Nullable< ^Value >) : Nullable< ^Value > = + let source = source.Source checkNonNull "source" source - use e = source.GetEnumerator() + use e = source.GetEnumerator() let mutable acc : ^Value = LanguagePrimitives.GenericZero< (^Value) > while e.MoveNext() do - let v : Nullable< ^Value > = valueSelector e.Current - if v.HasValue then + let v : Nullable< ^Value > = valueSelector e.Current + if v.HasValue then acc <- plus acc (v.Value : ^Value) Nullable acc - member inline __.AverageByNullable< 'T, 'Q, ^Value + member inline __.AverageByNullable< 'T, 'Q, ^Value when ^Value :> ValueType - and ^Value : struct - and ^Value : (new : unit -> ^Value) - and ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) - and ^Value : (static member DivideByInt : ^Value * int -> ^Value) - and ^Value : (static member Zero : ^Value) + and ^Value : struct + and ^Value : (new : unit -> ^Value) + and ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) + and ^Value : (static member DivideByInt : ^Value * int -> ^Value) + and ^Value : (static member Zero : ^Value) and default ^Value : float > - - (source: QuerySource<'T,'Q>, projection: 'T -> Nullable< ^Value >) : Nullable< ^Value > = + + (source: QuerySource<'T, 'Q>, projection: 'T -> Nullable< ^Value >) : Nullable< ^Value > = + let source = source.Source checkNonNull "source" source - use e = source.GetEnumerator() + use e = source.GetEnumerator() let mutable acc = LanguagePrimitives.GenericZero< (^Value) > let mutable count = 0 while e.MoveNext() do - let v = projection e.Current - if v.HasValue then + let v = projection e.Current + if v.HasValue then acc <- plus acc v.Value count <- count + 1 if count = 0 then Nullable() else Nullable(LanguagePrimitives.DivideByInt< (^Value) > acc count) - member inline __.AverageBy< 'T, 'Q, ^Value - when ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) - and ^Value : (static member DivideByInt : ^Value * int -> ^Value) - and ^Value : (static member Zero : ^Value) + member inline __.AverageBy< 'T, 'Q, ^Value + when ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) + and ^Value : (static member DivideByInt : ^Value * int -> ^Value) + and ^Value : (static member Zero : ^Value) and default ^Value : float > - (source: QuerySource<'T,'Q>, projection: 'T -> ^Value) : ^Value = + (source: QuerySource<'T, 'Q>, projection: 'T -> ^Value) : ^Value = + let source = source.Source checkNonNull "source" source - use e = source.GetEnumerator() + use e = source.GetEnumerator() let mutable acc = LanguagePrimitives.GenericZero< (^U) > let mutable count = 0 while e.MoveNext() do acc <- plus acc (projection e.Current) count <- count + 1 - if count = 0 then + if count = 0 then invalidOp "source" LanguagePrimitives.DivideByInt< (^U) > acc count - member inline __.SumBy< 'T, 'Q, ^Value - when ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) + member inline __.SumBy< 'T, 'Q, ^Value + when ^Value : (static member ( + ) : ^Value * ^Value -> ^Value) and ^Value : (static member Zero : ^Value) and default ^Value : int > - (source:QuerySource<'T,'Q>, projection : ('T -> ^Value)) : ^Value = + (source:QuerySource<'T, 'Q>, projection : ('T -> ^Value)) : ^Value = Seq.sumBy projection source.Source - member __.GroupBy (source: QuerySource<'T,'Q>, keySelector : _ -> 'Key) : QuerySource<_,'Q> when 'Key : equality = - QuerySource (Enumerable.GroupBy(source.Source, Func<_,_>(keySelector))) + member __.GroupBy (source: QuerySource<'T, 'Q>, keySelector : _ -> 'Key) : QuerySource<_, 'Q> when 'Key : equality = + QuerySource (Enumerable.GroupBy(source.Source, Func<_, _>(keySelector))) - member __.SortBy (source: QuerySource<'T,'Q>, keySelector : 'T -> 'Key) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.OrderBy(source.Source, Func<_,_>(keySelector))) + member __.SortBy (source: QuerySource<'T, 'Q>, keySelector : 'T -> 'Key) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.OrderBy(source.Source, Func<_, _>(keySelector))) - member __.SortByDescending (source: QuerySource<'T,'Q>, keySelector : 'T -> 'Key) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.OrderByDescending(source.Source, Func<_,_>(keySelector))) + member __.SortByDescending (source: QuerySource<'T, 'Q>, keySelector : 'T -> 'Key) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.OrderByDescending(source.Source, Func<_, _>(keySelector))) - member __.ThenBy (source: QuerySource<'T,'Q>, keySelector : 'T -> 'Key) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.ThenBy(checkThenBySource source.Source, Func<_,_>(keySelector))) + member __.ThenBy (source: QuerySource<'T, 'Q>, keySelector : 'T -> 'Key) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.ThenBy(checkThenBySource source.Source, Func<_, _>(keySelector))) - member __.ThenByDescending (source: QuerySource<'T,'Q>, keySelector : 'T -> 'Key) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.ThenByDescending(checkThenBySource source.Source, Func<_,_>(keySelector))) + member __.ThenByDescending (source: QuerySource<'T, 'Q>, keySelector : 'T -> 'Key) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.ThenByDescending(checkThenBySource source.Source, Func<_, _>(keySelector))) - member __.SortByNullable (source: QuerySource<'T,'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.OrderBy(source.Source, Func<_,_>(keySelector))) + member __.SortByNullable (source: QuerySource<'T, 'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.OrderBy(source.Source, Func<_, _>(keySelector))) - member __.SortByNullableDescending (source: QuerySource<'T,'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.OrderByDescending(source.Source, Func<_,_>(keySelector))) + member __.SortByNullableDescending (source: QuerySource<'T, 'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.OrderByDescending(source.Source, Func<_, _>(keySelector))) - member __.ThenByNullable (source: QuerySource<'T,'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.ThenBy(checkThenBySource source.Source, Func<_,_>(keySelector))) + member __.ThenByNullable (source: QuerySource<'T, 'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.ThenBy(checkThenBySource source.Source, Func<_, _>(keySelector))) - member __.ThenByNullableDescending (source: QuerySource<'T,'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T,'Q> when 'Key : equality and 'Key : comparison = - QuerySource (Enumerable.ThenByDescending(checkThenBySource source.Source, Func<_,_>(keySelector))) + member __.ThenByNullableDescending (source: QuerySource<'T, 'Q>, keySelector : 'T -> Nullable<'Key>) : QuerySource<'T, 'Q> when 'Key : equality and 'Key : comparison = + QuerySource (Enumerable.ThenByDescending(checkThenBySource source.Source, Func<_, _>(keySelector))) - member __.GroupValBy<'T,'Key,'Result, 'Q when 'Key : equality > (source:QuerySource<'T,'Q>, resultSelector: 'T -> 'Result, keySelector: 'T -> 'Key) : QuerySource,'Q> = - QuerySource (Enumerable.GroupBy(source.Source, Func<'T,'Key>(keySelector), Func<'T,'Result>(resultSelector))) + member __.GroupValBy<'T, 'Key, 'Result, 'Q when 'Key : equality > (source:QuerySource<'T, 'Q>, resultSelector: 'T -> 'Result, keySelector: 'T -> 'Key) : QuerySource, 'Q> = + QuerySource (Enumerable.GroupBy(source.Source, Func<'T, 'Key>(keySelector), Func<'T, 'Result>(resultSelector))) -#if SUPPORT_ZIP_IN_QUERIES - member __.Zip (firstSource, secondSource, elementSelector) = - Enumerable.Zip(firstSource, secondSource, Func<_,_,_>(elementSelector) ) -#endif - member __.Join (outerSource: QuerySource<_,'Q>, innerSource: QuerySource<_,'Q>, outerKeySelector, innerKeySelector, resultSelector) : QuerySource<_,'Q> = - QuerySource (Enumerable.Join(outerSource.Source, innerSource.Source, Func<_,_>(outerKeySelector), Func<_,_>(innerKeySelector), Func<_,_,_>(resultSelector))) + member __.Join (outerSource: QuerySource<_, 'Q>, innerSource: QuerySource<_, 'Q>, outerKeySelector, innerKeySelector, resultSelector) : QuerySource<_, 'Q> = + QuerySource (Enumerable.Join(outerSource.Source, innerSource.Source, Func<_, _>(outerKeySelector), Func<_, _>(innerKeySelector), Func<_, _, _>(resultSelector))) - member __.GroupJoin (outerSource: QuerySource<_,'Q>, innerSource: QuerySource<_,'Q>, outerKeySelector, innerKeySelector, resultSelector: _ -> seq<_> -> _) : QuerySource<_,'Q> = - QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_,_>(outerKeySelector), Func<_,_>(innerKeySelector), Func<_,_,_>(fun x g -> resultSelector x g))) + member __.GroupJoin (outerSource: QuerySource<_, 'Q>, innerSource: QuerySource<_, 'Q>, outerKeySelector, innerKeySelector, resultSelector: _ -> seq<_> -> _) : QuerySource<_, 'Q> = + QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_, _>(outerKeySelector), Func<_, _>(innerKeySelector), Func<_, _, _>(fun x g -> resultSelector x g))) - member __.LeftOuterJoin (outerSource:QuerySource<_,'Q>, innerSource: QuerySource<_,'Q>, outerKeySelector, innerKeySelector, resultSelector: _ -> seq<_> -> _) : QuerySource<_,'Q> = - QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_,_>(outerKeySelector), Func<_,_>(innerKeySelector), Func<_,_,_>(fun x g -> resultSelector x (g.DefaultIfEmpty())))) + member __.LeftOuterJoin (outerSource:QuerySource<_, 'Q>, innerSource: QuerySource<_, 'Q>, outerKeySelector, innerKeySelector, resultSelector: _ -> seq<_> -> _) : QuerySource<_, 'Q> = + QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_, _>(outerKeySelector), Func<_, _>(innerKeySelector), Func<_, _, _>(fun x g -> resultSelector x (g.DefaultIfEmpty())))) - member __.RunQueryAsValue (q:Quotations.Expr<'T>) : 'T = ForwardDeclarations.Query.Execute q + member __.RunQueryAsValue (q:Quotations.Expr<'T>) : 'T = + ForwardDeclarations.Query.Execute q - member __.RunQueryAsEnumerable (q:Quotations.Expr>) : IEnumerable<'T> = - let queryAfterEliminatingNestedQueries = ForwardDeclarations.Query.EliminateNestedQueries q + member __.RunQueryAsEnumerable (q:Quotations.Expr>) : IEnumerable<'T> = + let queryAfterEliminatingNestedQueries = ForwardDeclarations.Query.EliminateNestedQueries q let queryAfterCleanup = Microsoft.FSharp.Linq.RuntimeHelpers.Adapters.CleanupLeaf queryAfterEliminatingNestedQueries - (LeafExpressionConverter.EvaluateQuotation queryAfterCleanup :?> QuerySource<'T,IEnumerable>).Source + (LeafExpressionConverter.EvaluateQuotation queryAfterCleanup :?> QuerySource<'T, IEnumerable>).Source + + member __.RunQueryAsQueryable (q:Quotations.Expr>) : IQueryable<'T> = + ForwardDeclarations.Query.Execute q - member __.RunQueryAsQueryable (q:Quotations.Expr>) : IQueryable<'T> = ForwardDeclarations.Query.Execute q member this.Run q = this.RunQueryAsQueryable q -namespace Microsoft.FSharp.Linq.QueryRunExtensions +namespace Microsoft.FSharp.Linq.QueryRunExtensions open Microsoft.FSharp.Core [] - module LowPriority = + module LowPriority = type Microsoft.FSharp.Linq.QueryBuilder with [] member this.Run (q: Microsoft.FSharp.Quotations.Expr<'T>) = this.RunQueryAsValue q [] - module HighPriority = + module HighPriority = type Microsoft.FSharp.Linq.QueryBuilder with [] - member this.Run (q: Microsoft.FSharp.Quotations.Expr>) = this.RunQueryAsEnumerable q + member this.Run (q: Microsoft.FSharp.Quotations.Expr>) = this.RunQueryAsEnumerable q namespace Microsoft.FSharp.Linq @@ -258,138 +310,150 @@ open ReflectionAdapters [] module Query = - let ConvVar (v: Var) = + let ConvVar (v: Var) = Expression.Parameter(v.Type, v.Name) let asExpr x = (x :> Expression) - + let (|Getter|_|) (prop: PropertyInfo) = - match prop.GetGetMethod(true) with + match prop.GetGetMethod(true) with | null -> None | v -> Some v - // Match 'f x' - let (|SpecificCall1|_|) q = + // Match 'f x' + let (|SpecificCall1|_|) q = let (|CallQ|_|) = (|SpecificCallToMethod|_|) q function | CallQ (Some builderObj, tyargs, [arg1]) -> Some(builderObj, tyargs, arg1) - | _ -> None + | _ -> None - // Match 'f x y' or 'f (x,y)' - let (|SpecificCall2|_|) q = + // Match 'f x y' or 'f (x, y)' + let (|SpecificCall2|_|) q = let (|CallQ|_|) = (|SpecificCallToMethod|_|) q function - | CallQ (Some builderObj, tyargs, [arg1;arg2]) -> Some(builderObj, tyargs, arg1, arg2) - | _ -> None + | CallQ (Some builderObj, tyargs, [arg1; arg2]) -> Some(builderObj, tyargs, arg1, arg2) + | _ -> None - // Match 'f x y z' or 'f (x,y,z)' - let (|SpecificCall3|_|) q = + // Match 'f x y z' or 'f (x, y, z)' + let (|SpecificCall3|_|) q = let (|CallQ|_|) = (|SpecificCallToMethod|_|) q function - | CallQ (Some builderObj, tyargs, [arg1;arg2;arg3]) -> Some(builderObj, tyargs, arg1, arg2, arg3) - | _ -> None + | CallQ (Some builderObj, tyargs, [arg1; arg2; arg3]) -> Some(builderObj, tyargs, arg1, arg2, arg3) + | _ -> None - /// (fun (x,y) -> z) is represented as 'fun p -> let x = p#0 let y = p#1' etc. + /// (fun (x, y) -> z) is represented as 'fun p -> let x = p#0 let y = p#1' etc. /// This reverses this encoding, but does not de-tuple the input variable into multiple variables. let (|LambdaNoDetupling|_|) (lam: Expr) = /// Strip off the 'let' bindings for an LambdaNoDetupling let rec stripSuccessiveProjLets (p:Var) n expr = - match expr with - | Let(v1,(TupleGet(Var pA,m) as e1),rest) - when p = pA && m = n-> - let restvs,b = stripSuccessiveProjLets p (n+1) rest - (v1,e1)::restvs, b - | _ -> ([],expr) - match lam with - | Lambda(v,body) -> - let projs,b = stripSuccessiveProjLets v 0 body + match expr with + | Let(v1, (TupleGet(Var pA, m) as e1), rest) + when p = pA && m = n-> + let restvs, b = stripSuccessiveProjLets p (n+1) rest + (v1, e1)::restvs, b + | _ -> ([], expr) + match lam with + | Lambda(v, body) -> + let projs, b = stripSuccessiveProjLets v 0 body Some(v, projs, b) | _ -> None - - let restoreTupleProjections projs b = List.foldBack (fun (v,e) acc -> Expr.Let (v,e,acc)) projs b - - let (|LambdasNoDetupling|_|) (inpExpr: Expr) = - let rec loop rvs rprojs e = - match e with - | LambdaNoDetupling(v,projs,body) -> loop (v::rvs) (projs::rprojs) body - | _ -> - match rvs with + + let restoreTupleProjections projs b = List.foldBack (fun (v, e) acc -> Expr.Let (v, e, acc)) projs b + + let (|LambdasNoDetupling|_|) (inpExpr: Expr) = + let rec loop rvs rprojs e = + match e with + | LambdaNoDetupling(v, projs, body) -> loop (v::rvs) (projs::rprojs) body + | _ -> + match rvs with | [] -> None - | _ -> Some(List.rev rvs,restoreTupleProjections (List.concat (List.rev rprojs)) e) - loop [] [] inpExpr + | _ -> Some(List.rev rvs, restoreTupleProjections (List.concat (List.rev rprojs)) e) + loop [] [] inpExpr - let GetGenericMethodDefinition (methInfo:MethodInfo) = + let GetGenericMethodDefinition (methInfo:MethodInfo) = if methInfo.IsGenericMethod then methInfo.GetGenericMethodDefinition() else methInfo - let CallGenericStaticMethod (methHandle:System.RuntimeMethodHandle) = + let CallGenericStaticMethod (methHandle:System.RuntimeMethodHandle) = let methInfo = methHandle |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo - fun (tyargs: Type list, args: obj list) -> + fun (tyargs: Type list, args: obj list) -> let methInfo = if methInfo.IsGenericMethod then methInfo.MakeGenericMethod(Array.ofList tyargs) else methInfo - try + try methInfo.Invoke(null, Array.ofList args) - with :? System.Reflection.TargetInvocationException as exn -> + with :? System.Reflection.TargetInvocationException as exn -> raise exn.InnerException - let CallGenericInstanceMethod (methHandle:System.RuntimeMethodHandle) = + let CallGenericInstanceMethod (methHandle:System.RuntimeMethodHandle) = let methInfo = methHandle |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo - fun (objExpr:obj, tyargs: Type list, args: obj list) -> + fun (objExpr:obj, tyargs: Type list, args: obj list) -> let methInfo = if methInfo.IsGenericMethod then methInfo.MakeGenericMethod(Array.ofList tyargs) else methInfo - try + try methInfo.Invoke(objExpr, Array.ofList args) - with :? System.Reflection.TargetInvocationException as exn -> + with :? System.Reflection.TargetInvocationException as exn -> raise exn.InnerException - let BindGenericStaticMethod (methInfo:MethodInfo) tyargs = - if methInfo.IsGenericMethod then + let BindGenericStaticMethod (methInfo:MethodInfo) tyargs = + if methInfo.IsGenericMethod then methInfo.GetGenericMethodDefinition().MakeGenericMethod(Array.ofList tyargs) else methInfo - let MakeGenericStaticMethod (methHandle:System.RuntimeMethodHandle) = + let MakeGenericStaticMethod (methHandle:System.RuntimeMethodHandle) = let methInfo = methHandle |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo (fun (tyargs: Type list, args: Expr list) -> Expr.Call(BindGenericStaticMethod methInfo tyargs, args)) - let MakeGenericInstanceMethod (methHandle:System.RuntimeMethodHandle) = + let MakeGenericInstanceMethod (methHandle:System.RuntimeMethodHandle) = let methInfo = methHandle |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo (fun (obj:Expr, tyargs: Type list, args: Expr list) -> Expr.Call(obj, BindGenericStaticMethod methInfo tyargs, args)) - let ImplicitExpressionConversionHelperMethodInfo = + let ImplicitExpressionConversionHelperMethodInfo = methodhandleof (fun e -> LeafExpressionConverter.ImplicitExpressionConversionHelper e) - |> System.Reflection.MethodInfo.GetMethodFromHandle + |> System.Reflection.MethodInfo.GetMethodFromHandle :?> MethodInfo let MakeImplicitExpressionConversion (x:Expr) = Expr.Call(ImplicitExpressionConversionHelperMethodInfo.MakeGenericMethod [| x.Type |], [ x ]) let NT = typedefof> - let FT1 = typedefof> - let FT2 = typedefof> + + let FT1 = typedefof> + + let FT2 = typedefof> + let boolTy = typeof + let MakeNullableTy ty = NT.MakeGenericType [| ty |] + let MakeQueryFuncTy (dty, rty) = FT1.MakeGenericType [| dty; rty |] + let MakeQueryFunc2Ty (dty1, dty2, rty) = FT2.MakeGenericType [| dty1; dty2; rty |] let IEnumerableTypeDef = typedefof> + let IQueryableTypeDef = typedefof> - let QuerySourceTypeDef = typedefof> + + let QuerySourceTypeDef = typedefof> + let MakeIEnumerableTy dty= IEnumerableTypeDef.MakeGenericType [| dty|] + let MakeIQueryableTy dty= IQueryableTypeDef.MakeGenericType [| dty|] + let IsQuerySourceTy (ty: System.Type) = ty.IsGenericType && ty.GetGenericTypeDefinition() = QuerySourceTypeDef + let IsIQueryableTy (ty: System.Type) = ty.IsGenericType && ty.GetGenericTypeDefinition() = IQueryableTypeDef - let IsIEnumerableTy (ty: System.Type) = ty.IsGenericType && ty.GetGenericTypeDefinition() = IEnumerableTypeDef + let IsIEnumerableTy (ty: System.Type) = ty.IsGenericType && ty.GetGenericTypeDefinition() = IEnumerableTypeDef // Check a tag type on QuerySource is IQueryable let qTyIsIQueryable (ty : System.Type) = not (ty.Equals(typeof)) - - let FuncExprToDelegateExpr (srcTy, targetTy, v, body) = + + let FuncExprToDelegateExpr (srcTy, targetTy, v, body) = Expr.NewDelegate(Linq.Expressions.Expression.GetFuncType [| srcTy; targetTy |], [v], body) /// Project F# function expressions to Linq LambdaExpression nodes - let FuncExprToLinqFunc2Expression (srcTy, targetTy, v, body) = + let FuncExprToLinqFunc2Expression (srcTy, targetTy, v, body) = FuncExprToDelegateExpr(srcTy, targetTy, v, body) |> LeafExpressionConverter.QuotationToExpression - let FuncExprToLinqFunc2 (srcTy, targetTy, v, body) = + let FuncExprToLinqFunc2 (srcTy, targetTy, v, body) = FuncExprToDelegateExpr(srcTy, targetTy, v, body) |> LeafExpressionConverter.EvaluateQuotation let MakersCallers F = CallGenericStaticMethod F, MakeGenericStaticMethod F @@ -398,10 +462,10 @@ module Query = let MakersCallers2 FQ FE = MakersCallers FQ, MakersCallers FE - let MakeOrCallContainsOrElementAt FQ FE = + let MakeOrCallContainsOrElementAt FQ FE = let (CQ, MQ), (CE, ME) = MakersCallers2 FQ FE let Make (isIQ, srcItemTy:Type, src:Expr, key:Expr) = - if isIQ then + if isIQ then //let key = MakeImplicitExpressionConversion key MQ ([srcItemTy], [src; key]) else @@ -410,102 +474,100 @@ module Query = let Call (isIQ, srcItemTy, src:obj, key:Expr) = let key = key |> LeafExpressionConverter.EvaluateQuotation let C = if isIQ then CQ else CE - C ([srcItemTy], [src;box key]) + C ([srcItemTy], [src; box key]) Make, Call - let MakeContains, CallContains = - let FQ = methodhandleof (fun (x,y) -> System.Linq.Queryable.Contains(x,y)) - let FE = methodhandleof (fun (x,y) -> Enumerable.Contains(x, y)) + let MakeContains, CallContains = + let FQ = methodhandleof (fun (x, y) -> System.Linq.Queryable.Contains(x, y)) + let FE = methodhandleof (fun (x, y) -> Enumerable.Contains(x, y)) MakeOrCallContainsOrElementAt FQ FE - let MakeElementAt, CallElementAt = - let FQ = methodhandleof (fun (x,y) -> System.Linq.Queryable.ElementAt(x,y)) - let FE = methodhandleof (fun (x,y) -> Enumerable.ElementAt(x,y)) + let MakeElementAt, CallElementAt = + let FQ = methodhandleof (fun (x, y) -> System.Linq.Queryable.ElementAt(x, y)) + let FE = methodhandleof (fun (x, y) -> Enumerable.ElementAt(x, y)) MakeOrCallContainsOrElementAt FQ FE - let MakeOrCallMinByOrMaxBy FQ FE = + let MakeOrCallMinByOrMaxBy FQ FE = let (CQ, MQ), (CE, ME) = MakersCallers2 FQ FE let Make (isIQ, src:Expr, v:Var, valSelector:Expr) = let srcItemTy = v.Type let keyElemTy = valSelector.Type let valSelector = FuncExprToDelegateExpr (srcItemTy, keyElemTy, v, valSelector) - if isIQ then + if isIQ then let valSelector = MakeImplicitExpressionConversion valSelector - MQ ([srcItemTy;keyElemTy], [src;valSelector]) + MQ ([srcItemTy; keyElemTy], [src; valSelector]) else - ME ([srcItemTy;keyElemTy], [src;valSelector]) + ME ([srcItemTy; keyElemTy], [src; valSelector]) - let Call (isIQ, srcItemTy:Type,_keyItemTy:Type, src:obj, keyElemTy:Type, v:Var, res:Expr) = - if isIQ then + let Call (isIQ, srcItemTy:Type, _keyItemTy:Type, src:obj, keyElemTy:Type, v:Var, res:Expr) = + if isIQ then let selector = FuncExprToLinqFunc2Expression (srcItemTy, keyElemTy, v, res) - CQ ([srcItemTy;keyElemTy], [src;box selector]) - else + CQ ([srcItemTy; keyElemTy], [src; box selector]) + else let selector = FuncExprToLinqFunc2 (srcItemTy, keyElemTy, v, res) - CE ([srcItemTy;keyElemTy], [src;selector]) + CE ([srcItemTy; keyElemTy], [src; selector]) Make, Call - let (MakeMinBy: bool * Expr * Var * Expr -> Expr), (CallMinBy : bool * Type * Type * obj * Type * Var * Expr -> obj) = - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Min(x,y)) - let FE = methodhandleof (fun (x,y:Func<_,'Result>) -> Enumerable.Min(x,y)) + let (MakeMinBy: bool * Expr * Var * Expr -> Expr), (CallMinBy : bool * Type * Type * obj * Type * Var * Expr -> obj) = + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Min(x, y)) + let FE = methodhandleof (fun (x, y:Func<_, 'Result>) -> Enumerable.Min(x, y)) MakeOrCallMinByOrMaxBy FQ FE - - let MakeMaxBy, CallMaxBy = - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Max(x, y)) - let FE = methodhandleof (fun (x,y: Func<_,'Result>) -> Enumerable.Max(x, y)) + let MakeMaxBy, CallMaxBy = + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Max(x, y)) + let FE = methodhandleof (fun (x, y: Func<_, 'Result>) -> Enumerable.Max(x, y)) MakeOrCallMinByOrMaxBy FQ FE - let MakeMinByNullable, CallMinByNullable = + let MakeMinByNullable, CallMinByNullable = // Note there is no separate LINQ overload for Min on nullables - the one implementation just magically skips nullable elements - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Min(x, y)) - let FE = methodhandleof (fun (x,y:Func<_,'Result>) -> Enumerable.Min(x, y)) + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Min(x, y)) + let FE = methodhandleof (fun (x, y:Func<_, 'Result>) -> Enumerable.Min(x, y)) MakeOrCallMinByOrMaxBy FQ FE - let MakeMaxByNullable, CallMaxByNullable = + let MakeMaxByNullable, CallMaxByNullable = // Note there is no separate LINQ overload for Max on nullables - the one implementation just magically skips nullable elements - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Max(x,y)) - let FE = methodhandleof (fun (x,y:Func<_,'Result>) -> Enumerable.Max(x,y)) + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Max(x, y)) + let FE = methodhandleof (fun (x, y:Func<_, 'Result>) -> Enumerable.Max(x, y)) MakeOrCallMinByOrMaxBy FQ FE - let MakeOrCallAnyOrAllOrFirstFind FQ FE = + let MakeOrCallAnyOrAllOrFirstFind FQ FE = let (CQ, MQ), (CE, ME) = MakersCallers2 FQ FE let Make (isIQ, src:Expr, v:Var, predicate:Expr) = let srcItemTy= v.Type let predicate = FuncExprToDelegateExpr (srcItemTy, boolTy, v, predicate) - if isIQ then + if isIQ then let predicate = MakeImplicitExpressionConversion predicate MQ ([srcItemTy], [src; predicate]) else ME ([srcItemTy], [src; predicate]) let Call (isIQ, srcItemTy:Type, src:obj, v:Var, res:Expr) = - if isIQ then + if isIQ then let selector = FuncExprToLinqFunc2Expression (srcItemTy, boolTy, v, res) - CQ ([srcItemTy], [src;box selector]) - else + CQ ([srcItemTy], [src; box selector]) + else let selector = FuncExprToLinqFunc2 (srcItemTy, boolTy, v, res) - CE ([srcItemTy], [src;selector]) + CE ([srcItemTy], [src; selector]) Make, Call - let MakeAny, CallAny = - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Any(x,y)) - let FE = methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.Any(x,y)) + let MakeAny, CallAny = + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Any(x, y)) + let FE = methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.Any(x, y)) MakeOrCallAnyOrAllOrFirstFind FQ FE - let MakeAll, CallAll = - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.All(x,y)) - let FE = methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.All(x,y)) + let MakeAll, CallAll = + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.All(x, y)) + let FE = methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.All(x, y)) MakeOrCallAnyOrAllOrFirstFind FQ FE - let MakeFirstFind, CallFirstFind = - let FQ = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.First(x,y)) - let FE = methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.First(x,y)) + let MakeFirstFind, CallFirstFind = + let FQ = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.First(x, y)) + let FE = methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.First(x, y)) MakeOrCallAnyOrAllOrFirstFind FQ FE - - let MakeOrCallAverageByOrSumByGeneric (isNullable,fq_double, fq_single, fq_decimal, fq_int32, fq_int64, fe_double, fe_single, fe_decimal, fe_int32, fe_int64, FE) = + let MakeOrCallAverageByOrSumByGeneric (isNullable, fq_double, fq_single, fq_decimal, fq_int32, fq_int64, fe_double, fe_single, fe_decimal, fe_int32, fe_int64, FE) = let (cq_double, mq_double), (ce_double, me_double) = MakersCallers2 fq_double fe_double let (cq_single, mq_single), (ce_single, me_single) = MakersCallers2 fq_single fe_single let (cq_decimal, mq_decimal), (ce_decimal, me_decimal) = MakersCallers2 fq_decimal fe_decimal @@ -515,569 +577,605 @@ module Query = let (CE, ME) = MakersCallersInstance FE let failDueToUnsupportedInputTypeInSumByOrAverageBy() = invalidOp (SR.GetString(SR.failDueToUnsupportedInputTypeInSumByOrAverageBy)) - let Make (qb:Expr,isIQ, src:Expr, v:Var, res:Expr) = + let Make (qb:Expr, isIQ, src:Expr, v:Var, res:Expr) = let srcItemTy = v.Type let resTy = res.Type - let resTyNoNullable = - if isNullable then - assert resTy.IsGenericType; - assert (resTy.GetGenericTypeDefinition() = typedefof>); + let resTyNoNullable = + if isNullable then + assert resTy.IsGenericType + assert (resTy.GetGenericTypeDefinition() = typedefof>) resTy.GetGenericArguments().[0] - else + else resTy let selector = FuncExprToDelegateExpr (srcItemTy, resTy, v, res) - if isIQ then + if isIQ then let selector = MakeImplicitExpressionConversion selector - let maker = - match resTyNoNullable with - | ty when ty = typeof -> mq_double - | ty when ty = typeof -> mq_single - | ty when ty = typeof -> mq_decimal - | ty when ty = typeof -> mq_int32 - | ty when ty = typeof -> mq_int64 + let maker = + match resTyNoNullable with + | ty when ty = typeof -> mq_double + | ty when ty = typeof -> mq_single + | ty when ty = typeof -> mq_decimal + | ty when ty = typeof -> mq_int32 + | ty when ty = typeof -> mq_int64 | _ -> failDueToUnsupportedInputTypeInSumByOrAverageBy() - maker ([srcItemTy], [src;selector]) + maker ([srcItemTy], [src; selector]) else // Try to dynamically invoke a LINQ method if one exists, since these may be optimized over arrays etc. - match resTyNoNullable with - | ty when ty = typeof -> me_double ([srcItemTy], [src;selector]) - | ty when ty = typeof -> me_single ([srcItemTy], [src;selector]) - | ty when ty = typeof -> me_decimal ([srcItemTy], [src;selector]) - | ty when ty = typeof -> me_int32 ([srcItemTy], [src;selector]) - | ty when ty = typeof -> me_int64 ([srcItemTy], [src;selector]) - | _ -> - // The F# implementation needs a QuerySource as a parameter. + match resTyNoNullable with + | ty when ty = typeof -> me_double ([srcItemTy], [src; selector]) + | ty when ty = typeof -> me_single ([srcItemTy], [src; selector]) + | ty when ty = typeof -> me_decimal ([srcItemTy], [src; selector]) + | ty when ty = typeof -> me_int32 ([srcItemTy], [src; selector]) + | ty when ty = typeof -> me_int64 ([srcItemTy], [src; selector]) + | _ -> + // The F# implementation needs a QuerySource as a parameter. let qTy = typeof - let ctor = typedefof>.MakeGenericType([|srcItemTy;qTy|]).GetConstructors().[0] - let src = Expr.NewObject(ctor, [src]) - // The F# implementation needs an FSharpFunc as a parameter. - let selector = Expr.Lambda(v, res) - ME (qb, [srcItemTy;qTy;resTyNoNullable], [src;selector]) - - let Call (qb:obj,isIQ, srcItemTy:Type, resTyNoNullable:Type, src:obj, resTy:Type, v:Var, res:Expr) = - if isIQ then + let ctor = typedefof>.MakeGenericType([|srcItemTy; qTy|]).GetConstructors().[0] + let src = Expr.NewObject(ctor, [src]) + // The F# implementation needs an FSharpFunc as a parameter. + let selector = Expr.Lambda(v, res) + ME (qb, [srcItemTy; qTy; resTyNoNullable], [src; selector]) + + let Call (qb:obj, isIQ, srcItemTy:Type, resTyNoNullable:Type, src:obj, resTy:Type, v:Var, res:Expr) = + if isIQ then let selector = FuncExprToLinqFunc2Expression (srcItemTy, resTy, v, res) - let caller = - match resTyNoNullable with - | ty when ty = typeof -> cq_double - | ty when ty = typeof -> cq_single - | ty when ty = typeof -> cq_decimal - | ty when ty = typeof -> cq_int32 - | ty when ty = typeof -> cq_int64 + let caller = + match resTyNoNullable with + | ty when ty = typeof -> cq_double + | ty when ty = typeof -> cq_single + | ty when ty = typeof -> cq_decimal + | ty when ty = typeof -> cq_int32 + | ty when ty = typeof -> cq_int64 | _ -> failDueToUnsupportedInputTypeInSumByOrAverageBy() - caller ([srcItemTy], [src;box selector]) : obj + caller ([srcItemTy], [src; box selector]) : obj else // Try to dynamically invoke a LINQ method if one exists, since these may be optimized over arrays etc. - let linqMethOpt = - match resTyNoNullable with - | ty when ty = typeof -> Some ce_double - | ty when ty = typeof -> Some ce_single - | ty when ty = typeof -> Some ce_decimal - | ty when ty = typeof -> Some ce_int32 + let linqMethOpt = + match resTyNoNullable with + | ty when ty = typeof -> Some ce_double + | ty when ty = typeof -> Some ce_single + | ty when ty = typeof -> Some ce_decimal + | ty when ty = typeof -> Some ce_int32 | ty when ty = typeof -> Some ce_int64 | _ -> None - match linqMethOpt with - | Some ce -> + match linqMethOpt with + | Some ce -> // A LINQ method needs a Delegate as a parameter let selector = FuncExprToLinqFunc2 (srcItemTy, resTy, v, res) - ce ([srcItemTy], [src;selector]) - | None -> - // The F# implementation needs a QuerySource as a parameter. + ce ([srcItemTy], [src; selector]) + | None -> + // The F# implementation needs a QuerySource as a parameter. let qTy = typeof - let ctor = typedefof>.MakeGenericType([|srcItemTy;qTy|]).GetConstructors().[0] - let srcE = - try + let ctor = typedefof>.MakeGenericType([|srcItemTy; qTy|]).GetConstructors().[0] + let srcE = + try ctor.Invoke [|src|] - with :? System.Reflection.TargetInvocationException as exn -> + with :? System.Reflection.TargetInvocationException as exn -> raise exn.InnerException - - // The F# implementation needs an FSharpFunc as a parameter. + + // The F# implementation needs an FSharpFunc as a parameter. let selectorE = Expr.Lambda (v, res) |> LeafExpressionConverter.EvaluateQuotation - CE (qb, [srcItemTy;qTy;resTy], [srcE;selectorE]) + CE (qb, [srcItemTy; qTy; resTy], [srcE; selectorE]) Make, Call - let MakeAverageBy, CallAverageBy = - let FQ_double = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Average(x,y)) - let FQ_single = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Average(x,y)) - let FQ_decimal = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Average(x,y)) - let FQ_int32 = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Average(x,y)) - let FQ_int64 = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Average(x,y)) - let FE_double = methodhandleof (fun (x,y:Func<_,double>) -> Enumerable.Average(x,y)) - let FE_single = methodhandleof (fun (x,y:Func<_,single>) -> Enumerable.Average(x,y)) - let FE_decimal = methodhandleof (fun (x,y:Func<_,decimal>) -> Enumerable.Average(x,y)) - let FE_int32 = methodhandleof (fun (x,y:Func<_,int32>) -> Enumerable.Average(x,y)) - let FE_int64 = methodhandleof (fun (x,y:Func<_,int64>) -> Enumerable.Average(x,y)) - let FE = methodhandleof (fun (query:QueryBuilder,arg1:QuerySource<_,_>,arg2:_->double) -> query.AverageBy(arg1,arg2)) - MakeOrCallAverageByOrSumByGeneric (false,FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) - - let MakeAverageByNullable, CallAverageByNullable = - let FQ_double = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Average(x,y)) - let FQ_single = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Average(x,y)) - let FQ_decimal = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Average(x,y)) - let FQ_int32 = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Average(x,y)) - let FQ_int64 = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Average(x,y)) - let FE_double = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Average(x,y)) - let FE_single = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Average(x,y)) - let FE_decimal = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Average(x,y)) - let FE_int32 = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Average(x,y)) - let FE_int64 = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Average(x,y)) - let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_,_>, arg2:_->Nullable) -> query.AverageByNullable(arg1,arg2)) - MakeOrCallAverageByOrSumByGeneric (true,FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) - - - let MakeSumBy, CallSumBy = - let FQ_double = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_single = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_decimal = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_int32 = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_int64 = methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Sum(x,y)) - let FE_double = methodhandleof (fun (x,y:Func<_,double>) -> Enumerable.Sum(x,y)) - let FE_single = methodhandleof (fun (x,y:Func<_,single>) -> Enumerable.Sum(x,y)) - let FE_decimal = methodhandleof (fun (x,y:Func<_,decimal>) -> Enumerable.Sum(x,y)) - let FE_int32 = methodhandleof (fun (x,y:Func<_,int32>) -> Enumerable.Sum(x,y)) - let FE_int64 = methodhandleof (fun (x,y:Func<_,int64>) -> Enumerable.Sum(x,y)) - let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_,_>, arg2:_->double) -> query.SumBy(arg1,arg2)) - MakeOrCallAverageByOrSumByGeneric (false,FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) - - let MakeSumByNullable, CallSumByNullable = - let FQ_double = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_single = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_decimal = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_int32 = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Sum(x,y)) - let FQ_int64 = methodhandleof (fun (x,y:Expression>>) -> System.Linq.Queryable.Sum(x,y)) - let FE_double = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Sum(x,y)) - let FE_single = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Sum(x,y)) - let FE_decimal = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Sum(x,y)) - let FE_int32 = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Sum(x,y)) - let FE_int64 = methodhandleof (fun (x,y:Func<_,Nullable>) -> Enumerable.Sum(x,y)) - let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_,_>, arg2:_->Nullable) -> query.SumByNullable(arg1,arg2)) - MakeOrCallAverageByOrSumByGeneric (true,FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) - - let MakeOrCallSimpleOp FQ FE = + let MakeAverageBy, CallAverageBy = + let FQ_double = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Average(x, y)) + let FQ_single = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Average(x, y)) + let FQ_decimal = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Average(x, y)) + let FQ_int32 = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Average(x, y)) + let FQ_int64 = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Average(x, y)) + let FE_double = methodhandleof (fun (x, y:Func<_, double>) -> Enumerable.Average(x, y)) + let FE_single = methodhandleof (fun (x, y:Func<_, single>) -> Enumerable.Average(x, y)) + let FE_decimal = methodhandleof (fun (x, y:Func<_, decimal>) -> Enumerable.Average(x, y)) + let FE_int32 = methodhandleof (fun (x, y:Func<_, int32>) -> Enumerable.Average(x, y)) + let FE_int64 = methodhandleof (fun (x, y:Func<_, int64>) -> Enumerable.Average(x, y)) + let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_, _>, arg2:_->double) -> query.AverageBy(arg1, arg2)) + MakeOrCallAverageByOrSumByGeneric (false, FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) + + let MakeAverageByNullable, CallAverageByNullable = + let FQ_double = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Average(x, y)) + let FQ_single = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Average(x, y)) + let FQ_decimal = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Average(x, y)) + let FQ_int32 = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Average(x, y)) + let FQ_int64 = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Average(x, y)) + let FE_double = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Average(x, y)) + let FE_single = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Average(x, y)) + let FE_decimal = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Average(x, y)) + let FE_int32 = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Average(x, y)) + let FE_int64 = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Average(x, y)) + let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_, _>, arg2:_->Nullable) -> query.AverageByNullable(arg1, arg2)) + MakeOrCallAverageByOrSumByGeneric (true, FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) + + + let MakeSumBy, CallSumBy = + let FQ_double = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_single = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_decimal = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_int32 = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_int64 = methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Sum(x, y)) + let FE_double = methodhandleof (fun (x, y:Func<_, double>) -> Enumerable.Sum(x, y)) + let FE_single = methodhandleof (fun (x, y:Func<_, single>) -> Enumerable.Sum(x, y)) + let FE_decimal = methodhandleof (fun (x, y:Func<_, decimal>) -> Enumerable.Sum(x, y)) + let FE_int32 = methodhandleof (fun (x, y:Func<_, int32>) -> Enumerable.Sum(x, y)) + let FE_int64 = methodhandleof (fun (x, y:Func<_, int64>) -> Enumerable.Sum(x, y)) + let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_, _>, arg2:_->double) -> query.SumBy(arg1, arg2)) + MakeOrCallAverageByOrSumByGeneric (false, FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) + + let MakeSumByNullable, CallSumByNullable = + let FQ_double = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_single = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_decimal = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_int32 = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Sum(x, y)) + let FQ_int64 = methodhandleof (fun (x, y:Expression>>) -> System.Linq.Queryable.Sum(x, y)) + let FE_double = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Sum(x, y)) + let FE_single = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Sum(x, y)) + let FE_decimal = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Sum(x, y)) + let FE_int32 = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Sum(x, y)) + let FE_int64 = methodhandleof (fun (x, y:Func<_, Nullable>) -> Enumerable.Sum(x, y)) + let FE = methodhandleof (fun (query:QueryBuilder, arg1:QuerySource<_, _>, arg2:_->Nullable) -> query.SumByNullable(arg1, arg2)) + MakeOrCallAverageByOrSumByGeneric (true, FQ_double, FQ_single, FQ_decimal, FQ_int32, FQ_int64, FE_double, FE_single, FE_decimal, FE_int32, FE_int64, FE) + + let MakeOrCallSimpleOp FQ FE = let (CQ, MQ), (CE, ME) = MakersCallers2 FQ FE let Make (isIQ, srcItemTy, src:Expr) = - if isIQ then - MQ ([srcItemTy], [src]) - else + if isIQ then + MQ ([srcItemTy], [src]) + else ME ([srcItemTy], [src]) let Call (isIQ, srcItemTy, src) = (if isIQ then CQ else CE) ([srcItemTy], [src]) Make, Call - let MakeFirst, CallFirst = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.First x)) (methodhandleof (fun x -> Enumerable.First x)) - let MakeFirstOrDefault, CallFirstOrDefault = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.FirstOrDefault x)) (methodhandleof (fun x -> Enumerable.FirstOrDefault x)) - let MakeLast, CallLast = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.Last x)) (methodhandleof (fun x -> Enumerable.Last x)) - let MakeLastOrDefault, CallLastOrDefault = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.LastOrDefault x)) (methodhandleof (fun x -> Enumerable.LastOrDefault x)) - let MakeSingle, CallSingle = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.Single x)) (methodhandleof (fun x -> Enumerable.Single x)) + let MakeFirst, CallFirst = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.First x)) (methodhandleof (fun x -> Enumerable.First x)) + + let MakeFirstOrDefault, CallFirstOrDefault = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.FirstOrDefault x)) (methodhandleof (fun x -> Enumerable.FirstOrDefault x)) + + let MakeLast, CallLast = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.Last x)) (methodhandleof (fun x -> Enumerable.Last x)) + + let MakeLastOrDefault, CallLastOrDefault = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.LastOrDefault x)) (methodhandleof (fun x -> Enumerable.LastOrDefault x)) + + let MakeSingle, CallSingle = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.Single x)) (methodhandleof (fun x -> Enumerable.Single x)) + let MakeSingleOrDefault, CallSingleOrDefault = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.SingleOrDefault x)) (methodhandleof (fun x -> Enumerable.SingleOrDefault x)) - let MakeCount, CallCount = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.Count x)) (methodhandleof (fun x -> Enumerable.Count x)) + + let MakeCount, CallCount = MakeOrCallSimpleOp (methodhandleof (fun x -> System.Linq.Queryable.Count x)) (methodhandleof (fun x -> Enumerable.Count x)) let MakeDefaultIfEmpty = MakeGenericStaticMethod (methodhandleof (fun x -> Enumerable.DefaultIfEmpty(x))) - + /// Indicates if we can eliminate redundant 'Select(x=>x)' nodes - type CanEliminate = + type CanEliminate = /// Inside a query construct, can eliminate redundant 'Select' - | Yes = 0 + | Yes = 0 /// At the very outer of a query or nested query - can't eliminate redundant 'Select' | No = 1 - let MakeSelect = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Select(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.Select(x,y))) - fun (canElim,isIQ, src:Expr, v:Var, f:Expr) -> - + let MakeSelect = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Select(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.Select(x, y))) + fun (canElim, isIQ, src:Expr, v:Var, f:Expr) -> + // Eliminate degenerate 'Select(x => x)', except for the very outer-most cases - match f with + match f with | Patterns.Var(v2) when v = v2 && canElim = CanEliminate.Yes -> src - | _ -> + | _ -> let srcItemTy = v.Type let targetTy = f.Type let selector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, targetTy), [v], f) - - if isIQ then + + if isIQ then let selector = MakeImplicitExpressionConversion selector - FQ ([srcItemTy;targetTy], [src;selector]) + FQ ([srcItemTy; targetTy], [src; selector]) else //printfn "found FE" - FE ([srcItemTy;targetTy], [src;selector]) - - - let MakeAppend = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y) -> System.Linq.Queryable.Concat(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y) -> Enumerable.Concat(x,y))) - fun (isIQ, srcItemTy, src1:Expr, src2:Expr) -> - if isIQ then - FQ ([srcItemTy], [src1;src2]) - else - FE ([srcItemTy], [src1;src2]) - - let MakeAsQueryable = + FE ([srcItemTy; targetTy], [src; selector]) + + let MakeAppend = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y) -> System.Linq.Queryable.Concat(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y) -> Enumerable.Concat(x, y))) + fun (isIQ, srcItemTy, src1:Expr, src2:Expr) -> + if isIQ then + FQ ([srcItemTy], [src1; src2]) + else + FE ([srcItemTy], [src1; src2]) + + let MakeAsQueryable = let F = MakeGenericStaticMethod (methodhandleof (fun (x:seq<_>) -> System.Linq.Queryable.AsQueryable x)) - fun (ty, src) -> + fun (ty, src) -> F ([ty], [src]) - let MakeEnumerableEmpty = + let MakeEnumerableEmpty = let F = MakeGenericStaticMethod (methodhandleof (fun _x -> Enumerable.Empty())) - fun (ty) -> + fun (ty) -> F ([ty], []) - let MakeEmpty = - fun (ty) -> + let MakeEmpty = + fun (ty) -> MakeAsQueryable (ty, MakeEnumerableEmpty ty) - let MakeSelectMany = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x:IQueryable<_>,y:Expression>,z:Expression>) -> System.Linq.Queryable.SelectMany(x,y,z))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x:IEnumerable<_>,y:Func<_,_>,z:Func<_,_,_>) -> Enumerable.SelectMany(x,y,z))) - fun (isIQ, resTy:Type, src:Expr, srcItemVar:Var, interimSelectorBody:Expr, interimVar:Var, targetSelectorBody:Expr) -> + let MakeSelectMany = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x:IQueryable<_>, y:Expression>, z:Expression>) -> System.Linq.Queryable.SelectMany(x, y, z))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x:IEnumerable<_>, y:Func<_, _>, z:Func<_, _, _>) -> Enumerable.SelectMany(x, y, z))) + fun (isIQ, resTy:Type, src:Expr, srcItemVar:Var, interimSelectorBody:Expr, interimVar:Var, targetSelectorBody:Expr) -> let srcItemTy = srcItemVar.Type let interimTy = interimVar.Type let interimSelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, MakeIEnumerableTy interimTy), [srcItemVar], interimSelectorBody) - let targetSelector = Expr.NewDelegate(MakeQueryFunc2Ty(srcItemTy, interimTy, resTy), [srcItemVar;interimVar], targetSelectorBody) + let targetSelector = Expr.NewDelegate(MakeQueryFunc2Ty(srcItemTy, interimTy, resTy), [srcItemVar; interimVar], targetSelectorBody) - if isIQ then + if isIQ then let interimSelector = MakeImplicitExpressionConversion interimSelector let targetSelector = MakeImplicitExpressionConversion targetSelector - FQ ([srcItemTy;interimTy;resTy], [src;interimSelector;targetSelector]) + FQ ([srcItemTy; interimTy; resTy], [src; interimSelector; targetSelector]) else - FE ([srcItemTy;interimTy;resTy], [src;interimSelector;targetSelector]) + FE ([srcItemTy; interimTy; resTy], [src; interimSelector; targetSelector]) - - let MakeWhere = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.Where(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.Where(x,y))) - fun (isIQ, src:Expr, v:Var, f) -> + let MakeWhere = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.Where(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.Where(x, y))) + fun (isIQ, src:Expr, v:Var, f) -> let selector = Expr.NewDelegate(MakeQueryFuncTy(v.Type, typeof), [v], f) - if isIQ then + if isIQ then let selector = MakeImplicitExpressionConversion selector - FQ ([v.Type], [src;selector]) + FQ ([v.Type], [src; selector]) else - FE ([v.Type], [src;selector]) - - + FE ([v.Type], [src; selector]) - let MakeOrderByOrThenBy FQ FE = - fun (isIQ, src:Expr, v:Var, keySelector:Expr) -> + let MakeOrderByOrThenBy FQ FE = + fun (isIQ, src:Expr, v:Var, keySelector:Expr) -> let srcItemTy = v.Type let keyItemTy = keySelector.Type let selector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, keyItemTy), [v], keySelector) - if isIQ then + if isIQ then let selector = MakeImplicitExpressionConversion selector - FQ ([srcItemTy;keyItemTy], [src;selector]) + FQ ([srcItemTy; keyItemTy], [src; selector]) else - FE ([srcItemTy;keyItemTy], [src;selector]) + FE ([srcItemTy; keyItemTy], [src; selector]) - let MakeOrderBy = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.OrderBy(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.OrderBy(x,y))) + let MakeOrderBy = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.OrderBy(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.OrderBy(x, y))) MakeOrderByOrThenBy FQ FE - let MakeOrderByDescending = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.OrderByDescending(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.OrderByDescending(x,y))) + let MakeOrderByDescending = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.OrderByDescending(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.OrderByDescending(x, y))) MakeOrderByOrThenBy FQ FE - let MakeThenBy = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.ThenBy(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.ThenBy(x,y))) + let MakeThenBy = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.ThenBy(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.ThenBy(x, y))) MakeOrderByOrThenBy FQ FE - let MakeThenByDescending = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.ThenByDescending(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.ThenByDescending(x,y))) + let MakeThenByDescending = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.ThenByDescending(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.ThenByDescending(x, y))) MakeOrderByOrThenBy FQ FE // The keyItemTy differentiates these let MakeOrderByNullable = MakeOrderBy + let MakeOrderByNullableDescending = MakeOrderByDescending + let MakeThenByNullable = MakeThenBy + let MakeThenByNullableDescending = MakeThenByDescending - let GenMakeSkipWhileOrTakeWhile FQ FE = + let GenMakeSkipWhileOrTakeWhile FQ FE = let FQ = MakeGenericStaticMethod FQ let FE = MakeGenericStaticMethod FE - fun (isIQ, src:Expr, v:Var, predicate) -> + fun (isIQ, src:Expr, v:Var, predicate) -> let srcItemTy = v.Type let selector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, boolTy), [v], predicate) - if isIQ then + if isIQ then let selector = MakeImplicitExpressionConversion selector - FQ ([srcItemTy], [src;selector]) + FQ ([srcItemTy], [src; selector]) else - FE ([srcItemTy], [src;selector]) + FE ([srcItemTy], [src; selector]) - - let MakeSkipOrTake FQ FE = + let MakeSkipOrTake FQ FE = let FQ = MakeGenericStaticMethod FQ let FE = MakeGenericStaticMethod FE - fun (isIQ, srcItemTy, src:Expr, count) -> - if isIQ then - FQ ([srcItemTy], [src;count]) + fun (isIQ, srcItemTy, src:Expr, count) -> + if isIQ then + FQ ([srcItemTy], [src; count]) else - FE ([srcItemTy], [src;count]) + FE ([srcItemTy], [src; count]) - let MakeSkip = - MakeSkipOrTake (methodhandleof (fun (x,y) -> System.Linq.Queryable.Skip (x,y))) - (methodhandleof (fun (x,y) -> Enumerable.Skip (x,y))) + let MakeSkip = + MakeSkipOrTake + (methodhandleof (fun (x, y) -> System.Linq.Queryable.Skip (x, y))) + (methodhandleof (fun (x, y) -> Enumerable.Skip (x, y))) - let MakeTake = - MakeSkipOrTake (methodhandleof (fun (x,y) -> System.Linq.Queryable.Take (x,y))) - (methodhandleof (fun (x,y) -> Enumerable.Take (x,y))) + let MakeTake = + MakeSkipOrTake + (methodhandleof (fun (x, y) -> System.Linq.Queryable.Take (x, y))) + (methodhandleof (fun (x, y) -> Enumerable.Take (x, y))) - let MakeSkipWhile = - GenMakeSkipWhileOrTakeWhile (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.SkipWhile(x,y))) - (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.SkipWhile(x,y))) + let MakeSkipWhile = + GenMakeSkipWhileOrTakeWhile + (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.SkipWhile(x, y))) + (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.SkipWhile(x, y))) - let MakeTakeWhile = - GenMakeSkipWhileOrTakeWhile (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.TakeWhile(x,y))) - (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.TakeWhile(x,y))) + let MakeTakeWhile = + GenMakeSkipWhileOrTakeWhile + (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.TakeWhile(x, y))) + (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.TakeWhile(x, y))) - let MakeDistinct = + let MakeDistinct = let FQ = MakeGenericStaticMethod (methodhandleof (fun x -> System.Linq.Queryable.Distinct x)) let FE = MakeGenericStaticMethod (methodhandleof (fun x -> Enumerable.Distinct x)) - fun (isIQ, srcItemTy, src:Expr) -> - if isIQ then + fun (isIQ, srcItemTy, src:Expr) -> + if isIQ then FQ ([srcItemTy], [src]) else FE ([srcItemTy], [src]) - let MakeGroupBy = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>) -> System.Linq.Queryable.GroupBy(x,y))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>) -> Enumerable.GroupBy(x,y))) - fun (isIQ, src:Expr, v:Var, keySelector:Expr) -> + let MakeGroupBy = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>) -> System.Linq.Queryable.GroupBy(x, y))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>) -> Enumerable.GroupBy(x, y))) + fun (isIQ, src:Expr, v:Var, keySelector:Expr) -> let srcItemTy = v.Type let keyTy = keySelector.Type - let keySelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, keyTy), [v], keySelector) + let keySelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, keyTy), [v], keySelector) - if isIQ then + if isIQ then let keySelector = MakeImplicitExpressionConversion keySelector - FQ ([srcItemTy;keyTy], [src;keySelector]) + FQ ([srcItemTy; keyTy], [src; keySelector]) else - FE ([srcItemTy;keyTy], [src;keySelector]) + FE ([srcItemTy; keyTy], [src; keySelector]) - let MakeGroupValBy = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y:Expression>, z:Expression>) -> System.Linq.Queryable.GroupBy(x,y,z))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y:Func<_,_>, z:Func<_,_>) -> Enumerable.GroupBy(x,y,z))) - fun (isIQ, srcItemTy, keyTy, elementTy, src:Expr, v1, keySelector, v2, elementSelector) -> - let keySelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, keyTy), [v1], keySelector) - let elementSelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, elementTy), [v2], elementSelector) + let MakeGroupValBy = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (x, y:Expression>, z:Expression>) -> System.Linq.Queryable.GroupBy(x, y, z))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (x, y:Func<_, _>, z:Func<_, _>) -> Enumerable.GroupBy(x, y, z))) + fun (isIQ, srcItemTy, keyTy, elementTy, src:Expr, v1, keySelector, v2, elementSelector) -> + let keySelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, keyTy), [v1], keySelector) + let elementSelector = Expr.NewDelegate(MakeQueryFuncTy(srcItemTy, elementTy), [v2], elementSelector) - if isIQ then + if isIQ then let keySelector = MakeImplicitExpressionConversion keySelector let elementSelector = MakeImplicitExpressionConversion elementSelector - FQ ([srcItemTy;keyTy;elementTy], [src;keySelector;elementSelector]) + FQ ([srcItemTy; keyTy; elementTy], [src; keySelector; elementSelector]) else - FE ([srcItemTy;keyTy;elementTy], [src;keySelector;elementSelector]) + FE ([srcItemTy; keyTy; elementTy], [src; keySelector; elementSelector]) -#if SUPPORT_ZIP_IN_QUERIES - let MakeZip = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (x,y, z:Expression>) -> System.Linq.Queryable.Zip(x,y,z))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (x,y, z:Func<_,_,_>) -> Enumerable.Zip(x,y,z))) - fun (firstSourceTy, secondSourceTy, resTy, firstSource:Expr, secondSource:Expr, firstElementVar, secondElementVar, elementSelector) -> - let elementSelector = Expr.NewDelegate(MakeQueryFunc2Ty(firstSourceTy, secondSourceTy, resTy), [firstElementVar;secondElementVar], elementSelector) + let MakeJoin = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (a1, a2, a3:Expression>, a4:Expression>, a5:Expression>) -> System.Linq.Queryable.Join(a1, a2, a3, a4, a5))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (a1, a2, a3:Func<_, _>, a4:Func<_, _>, a5:Func<_, _, _>) -> Enumerable.Join(a1, a2, a3, a4, a5))) + fun (isIQ, outerSourceTy, innerSourceTy, keyTy, resTy, outerSource:Expr, innerSource:Expr, outerKeyVar, outerKeySelector, innerKeyVar, innerKeySelector, outerResultKeyVar, innerResultKeyVar, elementSelector) -> + let outerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(outerSourceTy, keyTy), [outerKeyVar], outerKeySelector) + let innerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(innerSourceTy, keyTy), [innerKeyVar], innerKeySelector) + let elementSelector = Expr.NewDelegate(MakeQueryFunc2Ty(outerSourceTy, innerSourceTy, resTy), [outerResultKeyVar; innerResultKeyVar], elementSelector) - if typeof.IsAssignableFrom(firstSource.Type) && typeof.IsAssignableFrom(secondSource.Type) then - let elementSelector = MakeImplicitExpressionConversion elementSelector - FQ ([firstSourceTy;secondSourceTy;resTy], [firstSource;secondSource;elementSelector]) - else - FE ([firstSourceTy;secondSourceTy;resTy], [firstSource;secondSource;elementSelector]) -#endif - - - - let MakeJoin = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (a1,a2,a3:Expression>,a4:Expression>,a5:Expression>) -> System.Linq.Queryable.Join(a1,a2,a3,a4,a5))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (a1,a2,a3:Func<_,_>,a4:Func<_,_>,a5:Func<_,_,_>) -> Enumerable.Join(a1,a2,a3,a4,a5))) - fun (isIQ, outerSourceTy, innerSourceTy, keyTy, resTy, outerSource:Expr, innerSource:Expr, outerKeyVar, outerKeySelector, innerKeyVar, innerKeySelector, outerResultKeyVar, innerResultKeyVar, elementSelector) -> - let outerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(outerSourceTy, keyTy), [outerKeyVar], outerKeySelector) - let innerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(innerSourceTy, keyTy), [innerKeyVar], innerKeySelector) - let elementSelector = Expr.NewDelegate(MakeQueryFunc2Ty(outerSourceTy, innerSourceTy, resTy), [outerResultKeyVar;innerResultKeyVar], elementSelector) - - if isIQ then + if isIQ then let outerKeySelector = MakeImplicitExpressionConversion outerKeySelector let innerKeySelector = MakeImplicitExpressionConversion innerKeySelector let elementSelector = MakeImplicitExpressionConversion elementSelector - FQ ([outerSourceTy;innerSourceTy;keyTy;resTy], [outerSource;innerSource;outerKeySelector;innerKeySelector;elementSelector]) + FQ ([outerSourceTy; innerSourceTy; keyTy; resTy], [outerSource; innerSource; outerKeySelector; innerKeySelector; elementSelector]) else - FE ([outerSourceTy;innerSourceTy;keyTy;resTy], [outerSource;innerSource;outerKeySelector;innerKeySelector;elementSelector]) - - - - let MakeGroupJoin = - let FQ = MakeGenericStaticMethod (methodhandleof (fun (a1,a2,a3:Expression>,a4:Expression>,a5:Expression>) -> System.Linq.Queryable.GroupJoin(a1,a2,a3,a4,a5))) - let FE = MakeGenericStaticMethod (methodhandleof (fun (a1,a2,a3:Func<_,_>,a4:Func<_,_>,a5:Func<_,_,_>) -> Enumerable.GroupJoin(a1,a2,a3,a4,a5))) - fun (isIQ, outerSourceTy, innerSourceTy, keyTy, resTy, outerSource:Expr, innerSource:Expr, outerKeyVar, outerKeySelector, innerKeyVar, innerKeySelector, outerResultKeyVar, innerResultGroupVar, elementSelector) -> - let outerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(outerSourceTy, keyTy), [outerKeyVar], outerKeySelector) - let innerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(innerSourceTy, keyTy), [innerKeyVar], innerKeySelector) - let elementSelector = Expr.NewDelegate(MakeQueryFunc2Ty(outerSourceTy, MakeIEnumerableTy(innerSourceTy), resTy), [outerResultKeyVar;innerResultGroupVar], elementSelector) - if isIQ then + FE ([outerSourceTy; innerSourceTy; keyTy; resTy], [outerSource; innerSource; outerKeySelector; innerKeySelector; elementSelector]) + + let MakeGroupJoin = + let FQ = MakeGenericStaticMethod (methodhandleof (fun (a1, a2, a3:Expression>, a4:Expression>, a5:Expression>) -> System.Linq.Queryable.GroupJoin(a1, a2, a3, a4, a5))) + let FE = MakeGenericStaticMethod (methodhandleof (fun (a1, a2, a3:Func<_, _>, a4:Func<_, _>, a5:Func<_, _, _>) -> Enumerable.GroupJoin(a1, a2, a3, a4, a5))) + fun (isIQ, outerSourceTy, innerSourceTy, keyTy, resTy, outerSource:Expr, innerSource:Expr, outerKeyVar, outerKeySelector, innerKeyVar, innerKeySelector, outerResultKeyVar, innerResultGroupVar, elementSelector) -> + let outerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(outerSourceTy, keyTy), [outerKeyVar], outerKeySelector) + let innerKeySelector = Expr.NewDelegate(MakeQueryFuncTy(innerSourceTy, keyTy), [innerKeyVar], innerKeySelector) + let elementSelector = Expr.NewDelegate(MakeQueryFunc2Ty(outerSourceTy, MakeIEnumerableTy(innerSourceTy), resTy), [outerResultKeyVar; innerResultGroupVar], elementSelector) + if isIQ then let outerKeySelector = MakeImplicitExpressionConversion outerKeySelector let innerKeySelector = MakeImplicitExpressionConversion innerKeySelector let elementSelector = MakeImplicitExpressionConversion elementSelector - FQ ([outerSourceTy;innerSourceTy;keyTy;resTy], [outerSource;innerSource;outerKeySelector;innerKeySelector;elementSelector]) + FQ ([outerSourceTy; innerSourceTy; keyTy; resTy], [outerSource; innerSource; outerKeySelector; innerKeySelector; elementSelector]) else - FE ([outerSourceTy;innerSourceTy;keyTy;resTy], [outerSource;innerSource;outerKeySelector;innerKeySelector;elementSelector]) - - + FE ([outerSourceTy; innerSourceTy; keyTy; resTy], [outerSource; innerSource; outerKeySelector; innerKeySelector; elementSelector]) - let RewriteExpr f (q : Expr) = - let rec walk (p : Expr) = - match f walk p with + let RewriteExpr f (q : Expr) = + let rec walk (p : Expr) = + match f walk p with | Some r -> r - | None -> - match p with + | None -> + match p with | ExprShape.ShapeCombination(comb, args) -> ExprShape.RebuildShapeCombination(comb, List.map walk args) | ExprShape.ShapeLambda(v, body) -> Expr.Lambda(v, walk body) | ExprShape.ShapeVar _ -> p walk q - - let (|LetExprReduction|_|) (p : Expr) = - match p with + let (|LetExprReduction|_|) (p : Expr) = + match p with | Let(v, e, body) -> let body = body.Substitute (fun v2 -> if v = v2 then Some e else None) Some body - + | _ -> None + let (|MacroReduction|_|) (p : Expr) = - let (|MacroReduction|_|) (p : Expr) = - match p with - | Applications(Lambdas(vs, body), args) when vs.Length = args.Length && List.forall2 (fun vs args -> List.length vs = List.length args) vs args -> + match p with + | Applications(Lambdas(vs, body), args) + when vs.Length = args.Length + && (vs, args) ||> List.forall2 (fun vs args -> vs.Length = args.Length) -> let tab = Map.ofSeq (List.concat (List.map2 List.zip vs args)) - let body = body.Substitute tab.TryFind + let body = body.Substitute tab.TryFind Some body // Macro - | PropertyGet(None, Getter(MethodWithReflectedDefinition(body)), []) -> + | PropertyGet(None, Getter(MethodWithReflectedDefinition(body)), []) -> Some body // Macro - | Call(None, MethodWithReflectedDefinition(Lambdas(vs, body)), args) -> - let tab = Map.ofSeq (List.concat (List.map2 (fun (vs:Var list) arg -> match vs, arg with [v], arg -> [(v, arg)] | vs, NewTuple(args) -> List.zip vs args | _ -> List.zip vs [arg]) vs args)) - let body = body.Substitute tab.TryFind + | Call(None, MethodWithReflectedDefinition(Lambdas(vs, body)), args) -> + let tab = + (vs, args) + ||> List.map2 (fun vs arg -> + match vs, arg with + | [v], arg -> [(v, arg)] + | vs, NewTuple(args) -> List.zip vs args + | _ -> List.zip vs [arg]) + |> List.concat |> Map.ofSeq + let body = body.Substitute tab.TryFind Some body - // Macro - eliminate 'let'. + // Macro - eliminate 'let'. // // Always eliminate these: - // - function definitions + // - function definitions // // Always eliminate these, which are representations introduced by F# quotations: // - let v1 = v2 // - let v1 = tupledArg.Item* // - let copyOfStruct = ... - | Let(v, e, body) when (match e with + | Let(v, e, body) when (match e with | Lambda _ -> true - | Var _ -> true - | TupleGet(Var tv, _) when tv.Name = "tupledArg" -> true + | Var _ -> true + | TupleGet(Var tv, _) when tv.Name = "tupledArg" -> true | _ when v.Name = "copyOfStruct" && v.Type.IsValueType -> true | _ -> false) -> let body = body.Substitute (fun v2 -> if v = v2 then Some e else None) Some body - + | _ -> None /// Expand 'let' and other 'macro' definitions in leaf expressions, because LINQ can't cope with them - let MacroExpand q = + let MacroExpand q = q |> RewriteExpr (fun walk p -> - match p with + match p with // Macro reduction - eliminate any 'let' in leaf expressions | MacroReduction reduced -> Some (walk reduced) | _ -> None) - let (|CallQueryBuilderRunQueryable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b :QueryBuilder, v) -> b.Run(v))) - let (|CallQueryBuilderRunValue|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr<'a>) -> b.Run(v)) : 'a) // type annotations here help overload resolution - let (|CallQueryBuilderRunEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr> ) -> b.Run(v))) // type annotations here help overload resolution - let (|CallQueryBuilderFor|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder,source:QuerySource,body) -> b.For(source,body))) - let (|CallQueryBuilderYield|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder,value) -> b.Yield value)) - let (|CallQueryBuilderYieldFrom|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder,values) -> b.YieldFrom values)) - let (|CallQueryBuilderZero|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder) -> b.Zero())) - let (|CallQueryBuilderSourceIQueryable|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder,value:IQueryable<_>) -> b.Source value)) - let (|CallQueryBuilderSourceIEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder,value:IEnumerable<_>) -> b.Source value)) - - let (|CallSortBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.SortBy(arg1,arg2))) - let (|CallSortByDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.SortByDescending(arg1,arg2))) - let (|CallThenBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.ThenBy(arg1,arg2) )) - let (|CallThenByDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.ThenByDescending(arg1,arg2))) - - let (|CallSortByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.SortByNullable(arg1,arg2))) - let (|CallSortByNullableDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.SortByNullableDescending(arg1,arg2))) - let (|CallThenByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.ThenByNullable(arg1,arg2))) - let (|CallThenByNullableDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.ThenByNullableDescending(arg1,arg2))) - - let (|CallGroupBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.GroupBy(arg1,arg2))) - let (|CallGroupValBy|_|) = (|SpecificCall3|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2,arg3) -> query.GroupValBy(arg1,arg2,arg3))) - let (|CallMinBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.MinBy(arg1,arg2))) - let (|CallMaxBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.MaxBy(arg1,arg2))) - let (|CallMinByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.MinByNullable(arg1,arg2))) - let (|CallMaxByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.MaxByNullable(arg1,arg2))) - let (|CallWhere|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Where(arg1,arg2))) - let (|CallHeadOrDefault|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,arg1) -> query.HeadOrDefault arg1)) - let (|CallLast|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,arg1) -> query.Last arg1)) - let (|CallLastOrDefault|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,arg1) -> query.LastOrDefault arg1)) - let (|CallExactlyOne|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,arg1) -> query.ExactlyOne arg1)) - let (|CallExactlyOneOrDefault|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,source) -> query.ExactlyOneOrDefault source)) - let (|CallSelect|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Select(arg1,arg2))) - let (|CallExists|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Exists(arg1,arg2))) - let (|CallForAll|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.All(arg1,arg2))) - let (|CallDistinct|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,keySelector) -> query.Distinct(keySelector))) - let (|CallTake|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Take(arg1,arg2))) - let (|CallTakeWhile|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.TakeWhile(arg1,arg2))) - let (|CallContains|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Contains(arg1,arg2))) - let (|CallNth|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Nth(arg1,arg2))) - let (|CallSkip|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Skip(arg1,arg2))) - let (|CallSkipWhile|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.SkipWhile(arg1,arg2))) -#if SUPPORT_ZIP_IN_QUERIES - let (|CallZip|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2,arg3) -> query.Zip(arg1,arg2,arg3))) -#endif - let (|CallJoin|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2,arg3,arg4,arg5) -> query.Join(arg1,arg2,arg3,arg4,arg5))) - let (|CallGroupJoin|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2,arg3,arg4,arg5) -> query.GroupJoin(arg1,arg2,arg3,arg4,arg5))) - let (|CallLeftOuterJoin|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2,arg3,arg4,arg5) -> query.LeftOuterJoin(arg1,arg2,arg3,arg4,arg5))) - let (|CallAverageBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1:QuerySource,arg2:(double->double)) -> query.AverageBy(arg1,arg2))) - let (|CallSumBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1:QuerySource,arg2:(double->double)) -> query.SumBy(arg1,arg2))) + let (|CallQueryBuilderRunQueryable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b :QueryBuilder, v) -> b.Run(v))) + + let (|CallQueryBuilderRunValue|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr<'a>) -> b.Run(v)) : 'a) + + let (|CallQueryBuilderRunEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr> ) -> b.Run(v))) + + let (|CallQueryBuilderFor|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder, source:QuerySource, body) -> b.For(source, body))) + + let (|CallQueryBuilderYield|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder, value) -> b.Yield value)) + + let (|CallQueryBuilderYieldFrom|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder, values) -> b.YieldFrom values)) + + let (|CallQueryBuilderZero|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder) -> b.Zero())) + + let (|CallQueryBuilderSourceIQueryable|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder, value:IQueryable<_>) -> b.Source value)) + + let (|CallQueryBuilderSourceIEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder, value:IEnumerable<_>) -> b.Source value)) + + let (|CallSortBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.SortBy(arg1, arg2))) + + let (|CallSortByDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.SortByDescending(arg1, arg2))) + + let (|CallThenBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.ThenBy(arg1, arg2) )) + + let (|CallThenByDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.ThenByDescending(arg1, arg2))) + + let (|CallSortByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.SortByNullable(arg1, arg2))) + + let (|CallSortByNullableDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.SortByNullableDescending(arg1, arg2))) + + let (|CallThenByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.ThenByNullable(arg1, arg2))) + + let (|CallThenByNullableDescending|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.ThenByNullableDescending(arg1, arg2))) + + let (|CallGroupBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.GroupBy(arg1, arg2))) + + let (|CallGroupValBy|_|) = (|SpecificCall3|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2, arg3) -> query.GroupValBy(arg1, arg2, arg3))) + + let (|CallMinBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.MinBy(arg1, arg2))) + + let (|CallMaxBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.MaxBy(arg1, arg2))) + + let (|CallMinByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.MinByNullable(arg1, arg2))) + + let (|CallMaxByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.MaxByNullable(arg1, arg2))) + + let (|CallWhere|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Where(arg1, arg2))) + + let (|CallHeadOrDefault|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, arg1) -> query.HeadOrDefault arg1)) + + let (|CallLast|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, arg1) -> query.Last arg1)) + + let (|CallLastOrDefault|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, arg1) -> query.LastOrDefault arg1)) + + let (|CallExactlyOne|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, arg1) -> query.ExactlyOne arg1)) + + let (|CallExactlyOneOrDefault|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, source) -> query.ExactlyOneOrDefault source)) + + let (|CallSelect|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Select(arg1, arg2))) + + let (|CallExists|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Exists(arg1, arg2))) + + let (|CallForAll|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.All(arg1, arg2))) + + let (|CallDistinct|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, keySelector) -> query.Distinct(keySelector))) + + let (|CallTake|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Take(arg1, arg2))) + + let (|CallTakeWhile|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.TakeWhile(arg1, arg2))) + + let (|CallContains|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Contains(arg1, arg2))) + + let (|CallNth|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Nth(arg1, arg2))) + + let (|CallSkip|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Skip(arg1, arg2))) + + let (|CallSkipWhile|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.SkipWhile(arg1, arg2))) + + let (|CallJoin|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2, arg3, arg4, arg5) -> query.Join(arg1, arg2, arg3, arg4, arg5))) + + let (|CallGroupJoin|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2, arg3, arg4, arg5) -> query.GroupJoin(arg1, arg2, arg3, arg4, arg5))) + + let (|CallLeftOuterJoin|_|) = (|SpecificCallToMethod|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2, arg3, arg4, arg5) -> query.LeftOuterJoin(arg1, arg2, arg3, arg4, arg5))) + + let (|CallAverageBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1:QuerySource, arg2:(double->double)) -> query.AverageBy(arg1, arg2))) + + let (|CallSumBy|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1:QuerySource, arg2:(double->double)) -> query.SumBy(arg1, arg2))) + + let (|CallAverageByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1:QuerySource, arg2:(double->Nullable)) -> query.AverageByNullable(arg1, arg2))) + + let (|CallSumByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1:QuerySource, arg2:(double->Nullable)) -> query.SumByNullable(arg1, arg2))) + + let (|CallCount|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, arg1) -> query.Count(arg1))) - let (|CallAverageByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1:QuerySource,arg2:(double->Nullable)) -> query.AverageByNullable(arg1,arg2))) - let (|CallSumByNullable|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1:QuerySource,arg2:(double->Nullable)) -> query.SumByNullable(arg1,arg2))) + let (|CallHead|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder, arg1) -> query.Head(arg1))) - let (|CallCount|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,arg1) -> query.Count(arg1))) - let (|CallHead|_|) = (|SpecificCall1|_|) (methodhandleof (fun (query:QueryBuilder,arg1) -> query.Head(arg1))) - let (|CallFind|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder,arg1,arg2) -> query.Find(arg1,arg2))) + let (|CallFind|_|) = (|SpecificCall2|_|) (methodhandleof (fun (query:QueryBuilder, arg1, arg2) -> query.Find(arg1, arg2))) - let (|ZeroOnElseBranch|_|) = function + let (|ZeroOnElseBranch|_|) = function // This is the shape for 'match e with ... -> ... | _ -> ()' - | Patterns.Sequential(Patterns.Value(null, _), CallQueryBuilderZero _) + | Patterns.Sequential(Patterns.Value(null, _), CallQueryBuilderZero _) // This is the shape for from 'if/then' | CallQueryBuilderZero _ -> Some() | _ -> None /// Given an expression involving mutable tuples logically corresponding to a "yield" or "select" with the given /// immutable-to-mutable conversion information, convert it back to an expression involving immutable tuples or records. - let rec ConvMutableToImmutable conv mutExpr = - match conv with - | TupleConv convs -> + let rec ConvMutableToImmutable conv mutExpr = + match conv with + | TupleConv convs -> Expr.NewTuple (convs |> List.mapi (fun i conv -> ConvMutableToImmutable conv (AnonymousObjectGet (mutExpr, i)))) - | RecordConv (typ, convs) -> + | RecordConv (typ, convs) -> Expr.NewRecord(typ, convs |> List.mapi (fun i conv -> ConvMutableToImmutable conv (AnonymousObjectGet (mutExpr, i)))) - | SeqConv conv -> + | SeqConv conv -> // At this point, we know the input is either an IQueryable or an IEnumerable. // If it is an IQueryable, we must return an IQueryable. let isIQ = IsIQueryableTy mutExpr.Type assert (IsIEnumerableTy mutExpr.Type || IsIQueryableTy mutExpr.Type) let mutElemTy = mutExpr.Type.GetGenericArguments().[0] - let mutExpr = if isIQ then Expr.Coerce(mutExpr,MakeIEnumerableTy mutElemTy) else mutExpr + let mutExpr = if isIQ then Expr.Coerce(mutExpr, MakeIEnumerableTy mutElemTy) else mutExpr // Generate "source.Select(fun v -> ...)" (remembering that Select is an extension member, i.e. static) let mutVar = new Var("v", mutElemTy) let mutToImmutConvExpr = ConvMutableToImmutable conv (Expr.Var mutVar) - let immutExpr = MakeSelect (CanEliminate.Yes,false,mutExpr,mutVar,mutToImmutConvExpr) + let immutExpr = MakeSelect (CanEliminate.Yes, false, mutExpr, mutVar, mutToImmutConvExpr) let immutElemTy = mutToImmutConvExpr.Type - let immutExprCoerced = if isIQ then MakeAsQueryable(immutElemTy,immutExpr) else immutExpr + let immutExprCoerced = if isIQ then MakeAsQueryable(immutElemTy, immutExpr) else immutExpr immutExprCoerced - | GroupingConv (immutKeyTy, immutElemTy, conv) -> + | GroupingConv (immutKeyTy, immutElemTy, conv) -> assert (mutExpr.Type.GetGenericTypeDefinition() = typedefof>) let mutElemTy = mutExpr.Type.GetGenericArguments().[1] @@ -1086,15 +1184,15 @@ module Query = // Generate "source.Select(fun v -> ...)" (remembering that Select is an extension member, i.e. static) let var = new Var("v", mutElemTy) let convExpr = ConvMutableToImmutable conv (Expr.Var var) - + // Construct an IGrouping - let args = + let args = [ Expr.PropertyGet(mutExpr, mutExpr.Type.GetProperty "Key") MakeSelect(CanEliminate.Yes, false, mutExpr, var, convExpr) ] Expr.Coerce(Expr.NewObject(immutGroupingTy.GetConstructors().[0], args), immutIGroupingTy) - | NoConv -> + | NoConv -> mutExpr /// Given the expressions for a function (fun immutConsumingVar -> immutConsumingExpr) operating over immutable tuple and record @@ -1102,13 +1200,13 @@ module Query = /// data says how immutable types have been replaced by mutable types in the type of the input variable. /// /// For example, if 'conv' is NoConv, then the input function will be returned unchanged. - /// + /// /// If 'conv' is a TupleConv, then the input function will accept immutable tuples, and the output - /// function will accept mutable tuples. In this case, the function is implemented by replacing + /// function will accept mutable tuples. In this case, the function is implemented by replacing /// uses of the immutConsumingVar in the body of immutConsumingExpr with a tuple expression built /// from the elements of mutConsumingVar, and then simplifying the overall result. - let ConvertImmutableConsumerToMutableConsumer conv (immutConsumingVar:Var, immutConsumingExpr:Expr) : Var * Expr = - match conv with + let ConvertImmutableConsumerToMutableConsumer conv (immutConsumingVar:Var, immutConsumingExpr:Expr) : Var * Expr = + match conv with | NoConv -> (immutConsumingVar, immutConsumingExpr) | _ -> let mutConsumingVarType = ConvImmutableTypeToMutableType conv immutConsumingVar.Type @@ -1120,131 +1218,135 @@ module Query = let mutConsumingExpr = SimplifyConsumingExpr mutConsumingExprBeforeSimplification mutConsumingVar, mutConsumingExpr - let (|AnyNestedQuery|_|) e = - match e with - | CallQueryBuilderRunValue (None, _, [_; QuoteTyped e ]) - | CallQueryBuilderRunEnumerable (None, _, [_; QuoteTyped e ]) + let (|AnyNestedQuery|_|) e = + match e with + | CallQueryBuilderRunValue (None, _, [_; QuoteTyped e ]) + | CallQueryBuilderRunEnumerable (None, _, [_; QuoteTyped e ]) | CallQueryBuilderRunQueryable (Some _, _, [ QuoteTyped e ]) -> Some e | _ -> None - let (|EnumerableNestedQuery|_|) e = - match e with - | CallQueryBuilderRunEnumerable (None, _, [_; QuoteTyped e ]) + let (|EnumerableNestedQuery|_|) e = + match e with + | CallQueryBuilderRunEnumerable (None, _, [_; QuoteTyped e ]) | CallQueryBuilderRunQueryable (Some _, _, [ QuoteTyped e ]) -> Some e | _ -> None - /// Represents the result of TransInner - either a normal expression, or something we're about to turn into + /// Represents the result of TransInner - either a normal expression, or something we're about to turn into /// a 'Select'. The 'Select' case can be eliminated if it is about to be the result of a SelectMany by /// changing - /// src.SelectMany(x => ix.Select(y => res)) + /// src.SelectMany(x => ix.Select(y => res)) /// to - /// src.SelectMany(x => ix, (x,y) => res) - [] - type TransInnerResult = + /// src.SelectMany(x => ix, (x, y) => res) + [] + type TransInnerResult = | Select of CanEliminate * bool * TransInnerResult * Var * Expr | Other of Expr | Source of Expr + static member MakeSelect (canElim, isQTy, mutSource, mutSelectorVar, mutSelectorBody) = // We can eliminate a Select if it is either selecting on a non-source or is being added in a inner position. - let canElim = - match mutSource with + let canElim = + match mutSource with | TransInnerResult.Source _ -> canElim | _ -> CanEliminate.Yes - // We eliminate the Select here to keep the information in 'mutSource' available, i.e. whether + // We eliminate the Select here to keep the information in 'mutSource' available, i.e. whether // the mutSource is a TransInnerResult.Source after elimination - match mutSelectorBody with + match mutSelectorBody with | Patterns.Var(v2) when mutSelectorVar = v2 && canElim = CanEliminate.Yes -> mutSource | _ -> Select(canElim, isQTy, mutSource, mutSelectorVar, mutSelectorBody) /// Commit the result of TransInner in the case where the result was not immediately inside a 'SelectMany' - let rec CommitTransInnerResult c = - match c with - | TransInnerResult.Source(res) -> res - | TransInnerResult.Other(res) -> res - | TransInnerResult.Select(canElim, isQTy, mutSource, mutSelectorVar, mutSelectorBody) -> - MakeSelect(canElim,isQTy, CommitTransInnerResult mutSource, mutSelectorVar, mutSelectorBody) - - /// Given a the inner of query expression in terms of query.For, query.Select, query.Yield, query.Where etc., - /// and including immutable tuples and immutable records, build an equivalent query expression - /// in terms of LINQ operators, operating over mutable tuples. Return the conversion + let rec CommitTransInnerResult c = + match c with + | TransInnerResult.Source res -> res + | TransInnerResult.Other res -> res + | TransInnerResult.Select(canElim, isQTy, mutSource, mutSelectorVar, mutSelectorBody) -> + MakeSelect(canElim, isQTy, CommitTransInnerResult mutSource, mutSelectorVar, mutSelectorBody) + + /// Given a the inner of query expression in terms of query.For, query.Select, query.Yield, query.Where etc., + /// and including immutable tuples and immutable records, build an equivalent query expression + /// in terms of LINQ operators, operating over mutable tuples. Return the conversion /// information for the immutable-to-mutable conversion performed so we can undo it where needed. /// /// Here 'inner' refers the the part of the query that produces a sequence of results. /// /// The output query will use either Queryable.* or Enumerable.* operators depending on whether /// the inputs to the queries have type IQueryable or IEnumerable. - let rec TransInner canElim check (immutQuery:Expr) = + let rec TransInner canElim check (immutQuery:Expr) = //assert (IsIQueryableTy immutQuery.Type || IsQuerySourceTy immutQuery.Type || IsIEnumerableTy immutQuery.Type) // printfn "TransInner: %A" tm - match immutQuery with + match immutQuery with - // Look through coercions, e.g. to IEnumerable - | Coerce (expr,_ty) -> + // Look through coercions, e.g. to IEnumerable + | Coerce (expr, _ty) -> TransInner canElim check expr - // Rewrite "for" into SelectMany. If the body of a "For" is nothing but Yield/IfThenElse, + // Rewrite "for" into SelectMany. If the body of a "For" is nothing but Yield/IfThenElse, // then it can be rewritten to Select + Where. // - // If the original body of the "for" in the text of the F# query expression uses "where" or - // any other custom operator, then the body of the "for" as presented to the quotation + // If the original body of the "for" in the text of the F# query expression uses "where" or + // any other custom operator, then the body of the "for" as presented to the quotation // rewrite has had the custom operator translation mechanism applied. In this case, the // body of the "for" will simply contain "yield". - - | CallQueryBuilderFor (_, [_;qTy;immutResElemTy;_], [immutSource; Lambda(immutSelectorVar, immutSelector) ]) -> - + + | CallQueryBuilderFor (_, [_; qTy; immutResElemTy; _], [immutSource; Lambda(immutSelectorVar, immutSelector) ]) -> + let mutSource, sourceConv = TransInner CanEliminate.Yes check immutSource // If the body of a "For" is nothing but Yield/IfThenElse/Where, then it can be fully rewritten away. - let rec TransFor mutSource immutSelector = - match immutSelector with + let rec TransFor mutSource immutSelector = + match immutSelector with - // query.For (source, (fun selectorVar -> yield res)) @> + // query.For (source, (fun selectorVar -> yield res)) @> // ~~> TRANS(source.Select(selectorVar -> res) - | CallQueryBuilderYield(_, _, immutSelectorBody) -> + | CallQueryBuilderYield(_, _, immutSelectorBody) -> - let mutSelectorVar, mutSelectorBody = ConvertImmutableConsumerToMutableConsumer sourceConv (immutSelectorVar, MacroExpand immutSelectorBody) + let mutSelectorVar, mutSelectorBody = ConvertImmutableConsumerToMutableConsumer sourceConv (immutSelectorVar, MacroExpand immutSelectorBody) let mutSelectorBody, selectorConv = ProduceMoreMutables TransInnerNoCheck mutSelectorBody let mutSelectorBody = CleanupLeaf mutSelectorBody TransInnerResult.MakeSelect (canElim, qTyIsIQueryable qTy, mutSource, mutSelectorVar, mutSelectorBody), selectorConv - | LetExprReduction reduced -> TransFor mutSource reduced - | MacroReduction reduced -> TransFor mutSource reduced + | LetExprReduction reduced -> + TransFor mutSource reduced + + | MacroReduction reduced -> + TransFor mutSource reduced - // query.For (source, (fun selectorVar -> if g then selectorBody else query.Zero())) @> + // query.For (source, (fun selectorVar -> if g then selectorBody else query.Zero())) @> // ~~> TRANS(query.For (source.Where(fun selectorVar -> g), (fun selectorVar -> selectorBody)) - | CallWhere (_, _, immutSelectorBody, Lambda(_, immutPredicateBody)) - | IfThenElse(immutPredicateBody, immutSelectorBody, ZeroOnElseBranch) -> + | CallWhere (_, _, immutSelectorBody, Lambda(_, immutPredicateBody)) + | IfThenElse (immutPredicateBody, immutSelectorBody, ZeroOnElseBranch) -> - let mutSelectorVar, mutPredicateBody = ConvertImmutableConsumerToMutableConsumer sourceConv (immutSelectorVar, MacroExpand immutPredicateBody) + let mutSelectorVar, mutPredicateBody = ConvertImmutableConsumerToMutableConsumer sourceConv (immutSelectorVar, MacroExpand immutPredicateBody) let mutSource = MakeWhere(qTyIsIQueryable qTy, CommitTransInnerResult mutSource, mutSelectorVar, mutPredicateBody) TransFor (TransInnerResult.Other mutSource) immutSelectorBody - // query.For (source, (fun selectorVar -> immutSelectorBody)) @> + // query.For (source, (fun selectorVar -> immutSelectorBody)) @> // ~~> source.SelectMany(fun selectorVar -> immutSelectorBody) | immutSelectorBody -> - let mutSelectorVar, immutSelectorBody = ConvertImmutableConsumerToMutableConsumer sourceConv (immutSelectorVar, MacroExpand immutSelectorBody) + let mutSelectorVar, immutSelectorBody = ConvertImmutableConsumerToMutableConsumer sourceConv (immutSelectorVar, MacroExpand immutSelectorBody) let (mutSelectorBodyInfo:TransInnerResult), selectorConv = TransInner CanEliminate.Yes check immutSelectorBody let mutElemTy = ConvImmutableTypeToMutableType selectorConv immutResElemTy /// Commit the result of TransInner in the case where the result is immediately inside a 'SelectMany' - let (mutInterimSelectorBodyPreCoerce:Expr), mutInterimVar, mutTargetSelector = - match mutSelectorBodyInfo with + let (mutInterimSelectorBodyPreCoerce:Expr), mutInterimVar, mutTargetSelector = + match mutSelectorBodyInfo with | TransInnerResult.Select(_, _, mutInterimSelectorSource, mutInterimVar, mutTargetSelector) -> CommitTransInnerResult mutInterimSelectorSource, mutInterimVar, mutTargetSelector - | _ -> + | _ -> let mutInterimSelectorBody = CommitTransInnerResult mutSelectorBodyInfo let mutInterimVar = Var("x", mutElemTy) let mutTargetSelector = Expr.Var(mutInterimVar) mutInterimSelectorBody, mutInterimVar, mutTargetSelector - + // IQueryable.SelectMany expects an IEnumerable return - let mutInterimSelectorBody = + let mutInterimSelectorBody = let mutSelectorBodyTy = mutInterimSelectorBodyPreCoerce.Type - if mutSelectorBodyTy.IsGenericType && mutSelectorBodyTy.GetGenericTypeDefinition() = typedefof> then + if mutSelectorBodyTy.IsGenericType && mutSelectorBodyTy.GetGenericTypeDefinition() = typedefof> then mutInterimSelectorBodyPreCoerce else let mutSeqTy = MakeIEnumerableTy mutInterimVar.Type @@ -1253,14 +1355,14 @@ module Query = TransFor mutSource immutSelector - - // These occur in the F# quotation form of F# sequence expressions - | CallWhere (_, [_;qTy], immutSource, Lambda(immutSelectorVar, immutPredicateBody)) -> + + // These occur in the F# quotation form of F# sequence expressions + | CallWhere (_, [_; qTy], immutSource, Lambda(immutSelectorVar, immutPredicateBody)) -> let mutSource, sourceConv, mutSelectorVar, mutPredicateBody = TransInnerApplicativeAndCommit check immutSource (immutSelectorVar, immutPredicateBody) TransInnerResult.Other(MakeWhere(qTyIsIQueryable qTy, mutSource, mutSelectorVar, mutPredicateBody)), sourceConv - | CallSelect (_, [_;qTy;_], mutSource, Lambda(immutSelectorVar, immutSelectorBody)) -> + | CallSelect (_, [_; qTy; _], mutSource, Lambda(immutSelectorVar, immutSelectorBody)) -> let mutSource, _sourceConv, mutSelectorVar, mutSelectorBody = TransInnerApplicative check mutSource (immutSelectorVar, immutSelectorBody) let mutSelectorBody, selectorConv = ProduceMoreMutables TransInnerNoCheck mutSelectorBody @@ -1270,228 +1372,269 @@ module Query = | CallQueryBuilderYieldFrom (_, _, [source]) -> TransInner canElim check source - | CallQueryBuilderYield(_, [elemTy; qTy], immutSelectorBody) -> + | CallQueryBuilderYield (_, [elemTy; qTy], immutSelectorBody) -> let immutSelectorBody = CleanupLeaf immutSelectorBody - let enumExpr = Expr.Coerce(Expr.NewArray(elemTy,[ immutSelectorBody ]), MakeIEnumerableTy elemTy) - let expr = - if qTyIsIQueryable qTy then + let enumExpr = Expr.Coerce(Expr.NewArray(elemTy, [ immutSelectorBody ]), MakeIEnumerableTy elemTy) + let expr = + if qTyIsIQueryable qTy then MakeAsQueryable(elemTy, enumExpr) else - enumExpr + enumExpr TransInnerResult.Other(expr), NoConv - | IfThenElse(g, t, e) -> - match MacroExpand e with - | ZeroOnElseBranch -> + | IfThenElse (g, t, e) -> + match MacroExpand e with + | ZeroOnElseBranch -> let t, tConv = TransInnerAndCommit CanEliminate.Yes check t TransInnerResult.Other(Expr.IfThenElse(g, t, MakeEmpty t.Type)), tConv - | _ -> + | _ -> if check then raise (NotSupportedException (SR.GetString(SR.unsupportedIfThenElse)) ) - else TransInnerResult.Other(e), NoConv - - | CallSortBy (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + TransInnerResult.Other(e), NoConv + + | CallSortBy (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeOrderBy (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallSortByDescending (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallSortByDescending (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeOrderByDescending (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallThenBy (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallThenBy (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeThenBy (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallThenByDescending (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallThenByDescending (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeThenByDescending (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallSortByNullable (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallSortByNullable (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeOrderByNullable (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallSortByNullableDescending(_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallSortByNullableDescending(_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeOrderByNullableDescending(qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallThenByNullable (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallThenByNullable (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeThenByNullable (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallThenByNullableDescending (_, [_;qTy;_], source, Lambda(v, keySelector)) -> + | CallThenByNullableDescending (_, [_; qTy; _], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeThenByNullableDescending (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallDistinct (_, [srcItemTy; qTy], source) -> - let source, sourceConv = TransInnerAndCommit CanEliminate.Yes check source - TransInnerResult.Other(MakeDistinct(qTyIsIQueryable qTy, ConvImmutableTypeToMutableType sourceConv srcItemTy,source)), sourceConv + | CallDistinct (_, [srcItemTy; qTy], source) -> + let source, sourceConv = TransInnerAndCommit CanEliminate.Yes check source + let srcItemTyR = ConvImmutableTypeToMutableType sourceConv srcItemTy + TransInnerResult.Other(MakeDistinct(qTyIsIQueryable qTy, srcItemTyR, source)), sourceConv - | CallSkip(_, [srcItemTy; qTy], source, count) -> - let source, sourceConv = TransInnerAndCommit CanEliminate.Yes check source - TransInnerResult.Other(MakeSkip(qTyIsIQueryable qTy, ConvImmutableTypeToMutableType sourceConv srcItemTy, source, MacroExpand count)), sourceConv + | CallSkip(_, [srcItemTy; qTy], source, count) -> + let source, sourceConv = TransInnerAndCommit CanEliminate.Yes check source + let srcItemTyR = ConvImmutableTypeToMutableType sourceConv srcItemTy + TransInnerResult.Other(MakeSkip(qTyIsIQueryable qTy, srcItemTyR, source, MacroExpand count)), sourceConv - | CallTake(_, [srcItemTy; qTy], source, count) -> - let source, sourceConv = TransInnerAndCommit CanEliminate.Yes check source - TransInnerResult.Other(MakeTake(qTyIsIQueryable qTy, ConvImmutableTypeToMutableType sourceConv srcItemTy, source, MacroExpand count)), sourceConv + | CallTake(_, [srcItemTy; qTy], source, count) -> + let source, sourceConv = TransInnerAndCommit CanEliminate.Yes check source + let srcItemTyR = ConvImmutableTypeToMutableType sourceConv srcItemTy + TransInnerResult.Other(MakeTake(qTyIsIQueryable qTy, srcItemTyR, source, MacroExpand count)), sourceConv - | CallSkipWhile(_, [_; qTy], source, Lambda(v, keySelector)) -> + | CallSkipWhile(_, [_; qTy], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeSkipWhile (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallTakeWhile(_, [_; qTy], source, Lambda(v, keySelector)) -> + | CallTakeWhile(_, [_; qTy], source, Lambda(v, keySelector)) -> let source, sourceConv, v, keySelector = TransInnerApplicativeAndCommit check source (v, keySelector) TransInnerResult.Other(MakeTakeWhile (qTyIsIQueryable qTy, source, v, keySelector)), sourceConv - | CallGroupBy(_, [_; qTy; _], immutSource, Lambda(immutVar, immutKeySelector)) -> + | CallGroupBy(_, [_; qTy; _], immutSource, Lambda(immutVar, immutKeySelector)) -> let mutSource, sourceConv = TransInnerAndCommit CanEliminate.Yes check immutSource - let mutVar, mutKeySelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar, MacroExpand immutKeySelector) - let conv = match sourceConv with NoConv -> NoConv | _ -> GroupingConv(immutKeySelector.Type,immutVar.Type,sourceConv) + let mutVar, mutKeySelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar, MacroExpand immutKeySelector) + let conv = + match sourceConv with + | NoConv -> NoConv + | _ -> GroupingConv(immutKeySelector.Type, immutVar.Type, sourceConv) TransInnerResult.Other(MakeGroupBy(qTyIsIQueryable qTy, mutSource, mutVar, mutKeySelector)), conv - | CallGroupValBy(_, [_; _; _; qTy], immutSource, Lambda(immutVar1, immutElementSelector), Lambda(immutVar2, immutKeySelector)) -> + | CallGroupValBy + (_, [_; _; _; qTy], + immutSource, + Lambda(immutVar1, immutElementSelector), + Lambda(immutVar2, immutKeySelector)) -> let mutSource, sourceConv = TransInnerAndCommit CanEliminate.Yes check immutSource - let mutVar2, mutKeySelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar2, MacroExpand immutKeySelector) - let mutVar1, mutElementSelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar1, MacroExpand immutElementSelector) + let mutVar2, mutKeySelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar2, MacroExpand immutKeySelector) + let mutVar1, mutElementSelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar1, MacroExpand immutElementSelector) let mutElementSelector, selectorConv = ProduceMoreMutables TransInnerNoCheck mutElementSelector let mutElementSelector = CleanupLeaf mutElementSelector - let conv = match selectorConv with NoConv -> NoConv | _ -> GroupingConv (immutKeySelector.Type,immutElementSelector.Type,selectorConv) + let conv = + match selectorConv with + | NoConv -> NoConv + | _ -> GroupingConv (immutKeySelector.Type, immutElementSelector.Type, selectorConv) TransInnerResult.Other(MakeGroupValBy(qTyIsIQueryable qTy, mutVar1.Type, mutKeySelector.Type, mutElementSelector.Type, mutSource, mutVar2, mutKeySelector, mutVar1, mutElementSelector)), conv -#if SUPPORT_ZIP_IN_QUERIES - | CallZip(None, [ firstSourceTy; secondSourceTy; resTy ], [firstSource;secondSource;LambdasNoDetupling([firstElementVar;secondElementVar], elementSelector)])-> - - MakeZip(firstSourceTy, secondSourceTy, resTy, TransInner CanEliminate.Yes firstSource, TransInner CanEliminate.Yes secondSource, firstElementVar, secondElementVar, MacroExpand elementSelector) -#endif - - | CallJoin(_, [_; qTy; _; _; _], [immutOuterSource;immutInnerSource; - Lambda(immutOuterKeyVar, immutOuterKeySelector); - Lambda(immutInnerKeyVar, immutInnerKeySelector); - LambdasNoDetupling([immutOuterResultGroupVar;immutInnerResultKeyVar], immutElementSelector)])-> + | CallJoin(_, [_; qTy; _; _; _], + [ immutOuterSource + immutInnerSource + Lambda(immutOuterKeyVar, immutOuterKeySelector) + Lambda(immutInnerKeyVar, immutInnerKeySelector) + LambdasNoDetupling([immutOuterResultGroupVar; immutInnerResultKeyVar], immutElementSelector)]) -> - let (mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar:Var, mutOuterKeySelector, mutInnerKeyVar:Var, mutInnerKeySelector:Expr) = + let (mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar:Var, mutOuterKeySelector, mutInnerKeyVar:Var, mutInnerKeySelector:Expr) = TransJoinInputs check (immutOuterSource, immutInnerSource, immutOuterKeyVar, immutOuterKeySelector, immutInnerKeyVar, immutInnerKeySelector) - let mutOuterResultVar,mutElementSelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterResultGroupVar, MacroExpand immutElementSelector) - let mutInnerResultKeyVar,mutElementSelector = ConvertImmutableConsumerToMutableConsumer innerSourceConv (immutInnerResultKeyVar, mutElementSelector) + let mutOuterResultVar, mutElementSelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterResultGroupVar, MacroExpand immutElementSelector) + let mutInnerResultKeyVar, mutElementSelector = ConvertImmutableConsumerToMutableConsumer innerSourceConv (immutInnerResultKeyVar, mutElementSelector) let mutElementSelector, elementSelectorConv = ProduceMoreMutables TransInnerNoCheck mutElementSelector let mutElementSelector = CleanupLeaf mutElementSelector - TransInnerResult.Other(MakeJoin(qTyIsIQueryable qTy, mutOuterKeyVar.Type, mutInnerKeyVar.Type, mutInnerKeySelector.Type, mutElementSelector.Type, mutOuterSource, mutInnerSource, mutOuterKeyVar, mutOuterKeySelector, mutInnerKeyVar, mutInnerKeySelector, mutOuterResultVar, mutInnerResultKeyVar, mutElementSelector)),elementSelectorConv - | CallGroupJoin(_, [_; qTy; _; _; _], [immutOuterSource;immutInnerSource;Lambda(immutOuterKeyVar, immutOuterKeySelector);Lambda(immutInnerKeyVar, immutInnerKeySelector);LambdasNoDetupling([immutOuterResultGroupVar;immutInnerResultGroupVar], immutElementSelector)])-> + let joinExpr = + MakeJoin + (qTyIsIQueryable qTy, mutOuterKeyVar.Type, mutInnerKeyVar.Type, mutInnerKeySelector.Type, + mutElementSelector.Type, mutOuterSource, mutInnerSource, mutOuterKeyVar, mutOuterKeySelector, + mutInnerKeyVar, mutInnerKeySelector, mutOuterResultVar, mutInnerResultKeyVar, mutElementSelector) + + TransInnerResult.Other joinExpr, elementSelectorConv - let (mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar:Var, mutOuterKeySelector, mutInnerKeyVar:Var, mutInnerKeySelector:Expr) = + | CallGroupJoin + (_, [_; qTy; _; _; _], + [ immutOuterSource + immutInnerSource + Lambda(immutOuterKeyVar, immutOuterKeySelector) + Lambda(immutInnerKeyVar, immutInnerKeySelector) + LambdasNoDetupling([immutOuterResultGroupVar; immutInnerResultGroupVar], immutElementSelector)]) -> + + let (mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar:Var, mutOuterKeySelector, mutInnerKeyVar:Var, mutInnerKeySelector:Expr) = TransJoinInputs check (immutOuterSource, immutInnerSource, immutOuterKeyVar, immutOuterKeySelector, immutInnerKeyVar, immutInnerKeySelector) - let mutOuterResultGroupVar,mutElementSelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterResultGroupVar, MacroExpand immutElementSelector) - let innerGroupConv = MakeSeqConv innerSourceConv - let mutInnerResultKeyVar,mutElementSelector = ConvertImmutableConsumerToMutableConsumer innerGroupConv (immutInnerResultGroupVar, mutElementSelector) + let mutOuterResultGroupVar, mutElementSelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterResultGroupVar, MacroExpand immutElementSelector) + let innerGroupConv = MakeSeqConv innerSourceConv + let mutInnerResultKeyVar, mutElementSelector = ConvertImmutableConsumerToMutableConsumer innerGroupConv (immutInnerResultGroupVar, mutElementSelector) let mutElementSelector, elementSelectorConv = ProduceMoreMutables TransInnerNoCheck mutElementSelector let mutElementSelector = CleanupLeaf mutElementSelector - TransInnerResult.Other(MakeGroupJoin(qTyIsIQueryable qTy, mutOuterKeyVar.Type, mutInnerKeyVar.Type, mutInnerKeySelector.Type, mutElementSelector.Type, mutOuterSource, mutInnerSource, mutOuterKeyVar, mutOuterKeySelector, mutInnerKeyVar, mutInnerKeySelector, mutOuterResultGroupVar, mutInnerResultKeyVar, mutElementSelector)), elementSelectorConv + let joinExpr = + MakeGroupJoin + (qTyIsIQueryable qTy, mutOuterKeyVar.Type, mutInnerKeyVar.Type, + mutInnerKeySelector.Type, mutElementSelector.Type, mutOuterSource, + mutInnerSource, mutOuterKeyVar, mutOuterKeySelector, mutInnerKeyVar, + mutInnerKeySelector, mutOuterResultGroupVar, mutInnerResultKeyVar, mutElementSelector) + + TransInnerResult.Other joinExpr, elementSelectorConv - | CallLeftOuterJoin(_, [ _; qTy; immutInnerSourceTy; _; _], [immutOuterSource;immutInnerSource;Lambda(immutOuterKeyVar, immutOuterKeySelector);Lambda(immutInnerKeyVar, immutInnerKeySelector);LambdasNoDetupling([immutOuterResultGroupVar;immutInnerResultGroupVar], immutElementSelector)])-> + | CallLeftOuterJoin + (_, [ _; qTy; immutInnerSourceTy; _; _], + [ immutOuterSource + immutInnerSource + Lambda(immutOuterKeyVar, immutOuterKeySelector) + Lambda(immutInnerKeyVar, immutInnerKeySelector) + LambdasNoDetupling([immutOuterResultGroupVar; immutInnerResultGroupVar], immutElementSelector)]) -> // Replace uses of 'innerResultGroupVar' with 'innerResultGroupVar.DefaultIfEmpty()' and call MakeGroupJoin let immutElementSelector = immutElementSelector.Substitute (fun v -> if v = immutInnerResultGroupVar then Some (MakeDefaultIfEmpty ([immutInnerSourceTy], [Expr.Var immutInnerResultGroupVar])) else None) - let (mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar:Var, mutOuterKeySelector, mutInnerKeyVar:Var, mutInnerKeySelector:Expr) = + let (mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar:Var, mutOuterKeySelector, mutInnerKeyVar:Var, mutInnerKeySelector:Expr) = TransJoinInputs check (immutOuterSource, immutInnerSource, immutOuterKeyVar, immutOuterKeySelector, immutInnerKeyVar, immutInnerKeySelector) - let mutOuterResultGroupVar,mutElementSelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterResultGroupVar, MacroExpand immutElementSelector) - let mutInnerResultKeyVar,mutElementSelector = ConvertImmutableConsumerToMutableConsumer innerSourceConv (immutInnerResultGroupVar, mutElementSelector) + let mutOuterResultGroupVar, mutElementSelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterResultGroupVar, MacroExpand immutElementSelector) + let mutInnerResultKeyVar, mutElementSelector = ConvertImmutableConsumerToMutableConsumer innerSourceConv (immutInnerResultGroupVar, mutElementSelector) let mutElementSelector, elementSelectorConv = ProduceMoreMutables TransInnerNoCheck mutElementSelector let mutElementSelector = CleanupLeaf mutElementSelector - TransInnerResult.Other(MakeGroupJoin(qTyIsIQueryable qTy, mutOuterKeyVar.Type, mutInnerKeyVar.Type, mutInnerKeySelector.Type, mutElementSelector.Type, mutOuterSource, mutInnerSource, mutOuterKeyVar, mutOuterKeySelector, mutInnerKeyVar, mutInnerKeySelector, mutOuterResultGroupVar, mutInnerResultKeyVar, mutElementSelector)), elementSelectorConv + let joinExpr = + MakeGroupJoin + (qTyIsIQueryable qTy, mutOuterKeyVar.Type, mutInnerKeyVar.Type, mutInnerKeySelector.Type, + mutElementSelector.Type, mutOuterSource, mutInnerSource, mutOuterKeyVar, mutOuterKeySelector, + mutInnerKeyVar, mutInnerKeySelector, mutOuterResultGroupVar, mutInnerResultKeyVar, mutElementSelector) - | LetExprReduction reduced -> TransInner canElim check reduced - | MacroReduction reduced -> TransInner canElim check reduced + TransInnerResult.Other joinExpr, elementSelectorConv + | LetExprReduction reduced -> + TransInner canElim check reduced - | CallQueryBuilderSourceIQueryable(_, _,expr) -> // expr when typeof.IsAssignableFrom(expr.Type) -> + | MacroReduction reduced -> + TransInner canElim check reduced + | CallQueryBuilderSourceIQueryable(_, _, expr) -> TransInnerResult.Source(expr), NoConv - | CallQueryBuilderSourceIEnumerable (_, _, expr) -> // expr when typeof.IsAssignableFrom(expr.Type) -> - //raise (NotSupportedException (Printf.sprintf "Unexpected use of query.Source with IEnumerable input: %A" immutQuery)) + | CallQueryBuilderSourceIEnumerable (_, _, expr) -> TransInnerResult.Source(expr), NoConv - | Call (_, meth, _) when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryCall),meth.ToString()))) + | Call (_, meth, _) when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryCall), meth.ToString()))) - | PropertyGet (_, pinfo, _) when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryProperty),pinfo.ToString()))) + | PropertyGet (_, pinfo, _) when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryProperty), pinfo.ToString()))) - | NewObject(ty,_) when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind),"new " + ty.ToString()))) + | NewObject(ty, _) when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind), "new " + ty.ToString()))) - | NewArray(ty,_) when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind),"NewArray(" + ty.Name + ",...)"))) + | NewArray(ty, _) when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind), "NewArray(" + ty.Name + ", ...)"))) - | NewTuple _ when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind),"NewTuple(...)"))) + | NewTuple _ when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind), "NewTuple(...)"))) - | FieldGet (_,field) when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind),"FieldGet(" + field.Name + ",...)"))) + | FieldGet (_, field) when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstructKind), "FieldGet(" + field.Name + ", ...)"))) - | LetRecursive _ when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct),"LetRecursive(...)"))) + | LetRecursive _ when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct), "LetRecursive(...)"))) - | NewRecord _ when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct),"NewRecord(...)"))) + | NewRecord _ when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct), "NewRecord(...)"))) - | NewDelegate _ when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct),"NewDelegate(...)"))) + | NewDelegate _ when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct), "NewDelegate(...)"))) - | NewTuple _ when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct),"NewTuple(...)"))) + | NewTuple _ when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct), "NewTuple(...)"))) - | NewUnionCase (ucase,_) when check -> - raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct),"NewUnionCase(" + ucase.Name + "...)"))) + | NewUnionCase (ucase, _) when check -> + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct), "NewUnionCase(" + ucase.Name + "...)"))) // Error cases - | e -> - if check then raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct),immutQuery.ToString()))) - else TransInnerResult.Source(e),NoConv - + | _ -> + if check then + raise (NotSupportedException (String.Format(SR.GetString(SR.unsupportedQueryConstruct), immutQuery.ToString()))) + TransInnerResult.Source immutQuery, NoConv - and TransInnerAndCommit canElim check x = + and TransInnerAndCommit canElim check x = let info, conv = TransInner canElim check x CommitTransInnerResult info, conv - and TransNone x = (x,NoConv) + and TransNone x = (x, NoConv) - // We translate nested queries directly in order to + // We translate nested queries directly in order to // propagate a immutable-->mutable-->immutable translation if any. // - /// This is used on recursive translations of yielded elements to translate nested queries - /// in 'yield' position and still propagate information about a possible imutable->mutable->mutable + /// This is used on recursive translations of yielded elements to translate nested queries + /// in 'yield' position and still propagate information about a possible imutable->mutable->mutable // translation. - // e.g. yield (1,query { ... }) - and TransInnerNoCheck e = - match e with - | EnumerableNestedQuery nestedQuery -> + // e.g. yield (1, query { ... }) + and TransInnerNoCheck e = + match e with + | EnumerableNestedQuery nestedQuery -> let replNestedQuery, conv = TransInnerAndCommit CanEliminate.Yes false nestedQuery - let replNestedQuery = + let replNestedQuery = let tyArg = replNestedQuery.Type.GetGenericArguments().[0] let IQueryableTySpec = MakeIQueryableTy tyArg - // if result type of nested query is derived from IQueryable but not IQueryable itself (i.e. IOrderedQueryable) + // if result type of nested query is derived from IQueryable but not IQueryable itself (i.e. IOrderedQueryable) // then add coercion to IQueryable so result type will match expected signature of QuerySource.Run if (IQueryableTySpec.IsAssignableFrom replNestedQuery.Type) && not (IQueryableTySpec.Equals replNestedQuery.Type) then Expr.Coerce(replNestedQuery, IQueryableTySpec) else replNestedQuery replNestedQuery, MakeSeqConv conv - | _ -> + | _ -> e, NoConv - and TransJoinInputs check (immutOuterSource, immutInnerSource, immutOuterKeyVar, immutOuterKeySelector, immutInnerKeyVar, immutInnerKeySelector) = + and TransJoinInputs check (immutOuterSource, immutInnerSource, immutOuterKeyVar, immutOuterKeySelector, immutInnerKeyVar, immutInnerKeySelector) = let mutOuterSource, outerSourceConv = TransInnerAndCommit CanEliminate.Yes check immutOuterSource let mutInnerSource, innerSourceConv = TransInnerAndCommit CanEliminate.Yes check immutInnerSource - let mutOuterKeyVar, mutOuterKeySelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterKeyVar, MacroExpand immutOuterKeySelector) - let mutInnerKeyVar, mutInnerKeySelector = ConvertImmutableConsumerToMutableConsumer innerSourceConv (immutInnerKeyVar, MacroExpand immutInnerKeySelector) + let mutOuterKeyVar, mutOuterKeySelector = ConvertImmutableConsumerToMutableConsumer outerSourceConv (immutOuterKeyVar, MacroExpand immutOuterKeySelector) + let mutInnerKeyVar, mutInnerKeySelector = ConvertImmutableConsumerToMutableConsumer innerSourceConv (immutInnerKeyVar, MacroExpand immutInnerKeySelector) // Keys may be composite tuples - convert them to be mutables. Note, if there is a tuple on one side, there must be a tuple on the other side. let mutOuterKeySelector, _ = ProduceMoreMutables TransNone mutOuterKeySelector @@ -1500,187 +1643,190 @@ module Query = let mutInnerKeySelector = CleanupLeaf mutInnerKeySelector mutOuterSource, outerSourceConv, mutInnerSource, innerSourceConv, mutOuterKeyVar, mutOuterKeySelector, mutInnerKeyVar, mutInnerKeySelector - /// Given a query expression in terms of query.For, query.Select, query.Yield, query.Where etc., - /// and including immutable tuples and immutable records, build an equivalent query expression - /// in terms of LINQ operators, operating over mutable tuples. Return the conversion + /// Given a query expression in terms of query.For, query.Select, query.Yield, query.Where etc., + /// and including immutable tuples and immutable records, build an equivalent query expression + /// in terms of LINQ operators, operating over mutable tuples. Return the conversion /// information for the immutable-to-mutable conversion performed so we can undo it where needed. /// /// Further, assume that the elements produced by the query will be consumed by the function "(fun immutConsumingVar -> immutConsumingExpr)" - /// and produce the expressions for a new function that consume the results directly. - and TransInnerApplicative check source (immutConsumingVar, immutConsumingExpr) = + /// and produce the expressions for a new function that consume the results directly. + and TransInnerApplicative check source (immutConsumingVar, immutConsumingExpr) = let source, sourceConv = TransInner CanEliminate.Yes check source - let mutConsumingVar, mutConsumingExpr = ConvertImmutableConsumerToMutableConsumer sourceConv (immutConsumingVar, MacroExpand immutConsumingExpr) + let mutConsumingVar, mutConsumingExpr = ConvertImmutableConsumerToMutableConsumer sourceConv (immutConsumingVar, MacroExpand immutConsumingExpr) source, sourceConv, mutConsumingVar, mutConsumingExpr - and TransInnerApplicativeAndCommit check source (immutConsumingVar, immutConsumingExpr) = + and TransInnerApplicativeAndCommit check source (immutConsumingVar, immutConsumingExpr) = let source, sourceConv, mutConsumingVar, mutConsumingExpr = TransInnerApplicative check source (immutConsumingVar, immutConsumingExpr) CommitTransInnerResult source, sourceConv, mutConsumingVar, mutConsumingExpr - /// Given a query expression in terms of query.For, query.Select, query.Yield, query.Where etc., - /// and including immutable tuples and immutable records, build an equivalent query expression + /// Given a query expression in terms of query.For, query.Select, query.Yield, query.Where etc., + /// and including immutable tuples and immutable records, build an equivalent query expression /// in terms of LINQ operators, operating over mutable tuples. If necessary, also add a "postifx" in-memory transformation /// converting the data back to immutable tuples and records. - let TransInnerWithFinalConsume canElim immutSource = + let TransInnerWithFinalConsume canElim immutSource = let mutSource, sourceConv = TransInnerAndCommit canElim true immutSource - match sourceConv with - | NoConv -> + match sourceConv with + | NoConv -> mutSource - | _ -> - // This function is used with inputs of - // - QuerySource<_,_> (for operators like Min) + | _ -> + // This function is used with inputs of + // - QuerySource<_, _> (for operators like Min) // - IQueryable<_> (for operators like MinBy) // - IEnumerable<_> (for nested queries) let immutSourceTy = immutSource.Type - let immutSourceElemTy = - assert immutSourceTy.IsGenericType; - assert (IsQuerySourceTy immutSourceTy || IsIQueryableTy immutSourceTy || IsIEnumerableTy immutSourceTy); + let immutSourceElemTy = + assert immutSourceTy.IsGenericType + assert (IsQuerySourceTy immutSourceTy || IsIQueryableTy immutSourceTy || IsIEnumerableTy immutSourceTy) immutSource.Type.GetGenericArguments().[0] - let immutVar = Var("after",immutSourceElemTy) - let mutVar, mutToImmutSelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar, Expr.Var immutVar) + let immutVar = Var("after", immutSourceElemTy) + let mutVar, mutToImmutSelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar, Expr.Var immutVar) let immutExprEnumerable = MakeSelect(CanEliminate.Yes, false, mutSource, mutVar, mutToImmutSelector) - let mustReturnIQueryable = - IsQuerySourceTy immutSourceTy && qTyIsIQueryable (immutSourceTy.GetGenericArguments().[1]) || + let mustReturnIQueryable = + IsQuerySourceTy immutSourceTy && qTyIsIQueryable (immutSourceTy.GetGenericArguments().[1]) || IsIQueryableTy immutSourceTy - let immutExprFinal = - if mustReturnIQueryable then MakeAsQueryable(immutSourceElemTy,immutExprEnumerable) + let immutExprFinal = + if mustReturnIQueryable then MakeAsQueryable(immutSourceElemTy, immutExprEnumerable) else immutExprEnumerable immutExprFinal - /// Like TransInnerApplicativeAndCommit but (a) assumes the query is nested and (b) throws away the conversion information, + /// Like TransInnerApplicativeAndCommit but (a) assumes the query is nested and (b) throws away the conversion information, /// i.e. assumes that the function "(fun immutConsumingVar -> immutConsumingExpr)" is the only consumption of the query. - let TransNestedInnerWithConsumer immutSource (immutConsumingVar, immutConsumingExpr) = + let TransNestedInnerWithConsumer immutSource (immutConsumingVar, immutConsumingExpr) = let mutSource, _sourceConv, mutConsumingVar, mutConsumingExpr = TransInnerApplicativeAndCommit true immutSource (immutConsumingVar, immutConsumingExpr) mutSource, mutConsumingVar, mutConsumingExpr - /// Translate nested query combinator calls to LINQ calls. - let rec TransNestedOuter canElim quot = + /// Translate nested query combinator calls to LINQ calls. + let rec TransNestedOuter canElim quot = match quot with - | CallMinBy (_, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallMinBy (_, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeMinBy (qTyIsIQueryable qTy, source, v, valSelector) + MakeMinBy (qTyIsIQueryable qTy, source, v, valSelector) - | CallMaxBy (_, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallMaxBy (_, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeMaxBy (qTyIsIQueryable qTy, source, v, valSelector) + MakeMaxBy (qTyIsIQueryable qTy, source, v, valSelector) - | CallMinByNullable (_, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallMinByNullable (_, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeMinByNullable (qTyIsIQueryable qTy, source, v, valSelector) + MakeMinByNullable (qTyIsIQueryable qTy, source, v, valSelector) - | CallMaxByNullable (_, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallMaxByNullable (_, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeMaxByNullable (qTyIsIQueryable qTy, source, v, valSelector) + MakeMaxByNullable (qTyIsIQueryable qTy, source, v, valSelector) - | CallCount (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeCount (qTyIsIQueryable qTy, srcItemTy, source) + | CallCount (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeCount (qTyIsIQueryable qTy, srcItemTy, source) - | CallHead (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeFirst (qTyIsIQueryable qTy, srcItemTy, source) + | CallHead (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeFirst (qTyIsIQueryable qTy, srcItemTy, source) - | CallLast (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeLast (qTyIsIQueryable qTy, srcItemTy, source) + | CallLast (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeLast (qTyIsIQueryable qTy, srcItemTy, source) - | CallHeadOrDefault (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source + | CallHeadOrDefault (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source MakeFirstOrDefault (qTyIsIQueryable qTy, srcItemTy, source) - | CallLastOrDefault (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeLastOrDefault (qTyIsIQueryable qTy, srcItemTy, source) + | CallLastOrDefault (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeLastOrDefault (qTyIsIQueryable qTy, srcItemTy, source) - | CallExactlyOne (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeSingle (qTyIsIQueryable qTy, srcItemTy, source) + | CallExactlyOne (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeSingle (qTyIsIQueryable qTy, srcItemTy, source) - | CallExactlyOneOrDefault (_, [srcItemTy; qTy], source) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source + | CallExactlyOneOrDefault (_, [srcItemTy; qTy], source) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source MakeSingleOrDefault(qTyIsIQueryable qTy, srcItemTy, source) - | CallAverageBy (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallAverageBy (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeAverageBy (qb, qTyIsIQueryable qTy, source, v, valSelector) + MakeAverageBy (qb, qTyIsIQueryable qTy, source, v, valSelector) - | CallAverageByNullable (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallAverageByNullable (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) MakeAverageByNullable(qb, qTyIsIQueryable qTy, source, v, valSelector) - | CallSumBy (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallSumBy (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeSumBy (qb, qTyIsIQueryable qTy, source, v, valSelector) + MakeSumBy (qb, qTyIsIQueryable qTy, source, v, valSelector) - | CallSumByNullable (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> + | CallSumByNullable (qb, [_; qTy; _], source, Lambda(v, valSelector)) -> let source, v, valSelector = TransNestedInnerWithConsumer source (v, valSelector) - MakeSumByNullable (qb, qTyIsIQueryable qTy, source, v, valSelector) + MakeSumByNullable (qb, qTyIsIQueryable qTy, source, v, valSelector) - | CallExists (_, [_; qTy], source, Lambda(v, predicate)) -> + | CallExists (_, [_; qTy], source, Lambda(v, predicate)) -> let source, v, predicate = TransNestedInnerWithConsumer source (v, predicate) - MakeAny (qTyIsIQueryable qTy, source, v, predicate) + MakeAny (qTyIsIQueryable qTy, source, v, predicate) - | CallForAll (_, [_; qTy], source, Lambda(v, predicate)) -> + | CallForAll (_, [_; qTy], source, Lambda(v, predicate)) -> let source, v, predicate = TransNestedInnerWithConsumer source (v, predicate) - MakeAll (qTyIsIQueryable qTy, source, v, predicate) + MakeAll (qTyIsIQueryable qTy, source, v, predicate) - | CallFind (_, [_; qTy], source, Lambda(v, predicate)) -> + | CallFind (_, [_; qTy], source, Lambda(v, predicate)) -> let source, v, predicate = TransNestedInnerWithConsumer source (v, predicate) - MakeFirstFind (qTyIsIQueryable qTy, source, v, predicate) + MakeFirstFind (qTyIsIQueryable qTy, source, v, predicate) - | CallContains (_, [srcItemTy; qTy], source, valToFindExpr) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeContains (qTyIsIQueryable qTy, srcItemTy, source, MacroExpand valToFindExpr) + | CallContains (_, [srcItemTy; qTy], source, valToFindExpr) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeContains (qTyIsIQueryable qTy, srcItemTy, source, MacroExpand valToFindExpr) - | CallNth (_, [srcItemTy; qTy], source, valCountExpr) -> - let source = TransInnerWithFinalConsume CanEliminate.Yes source - MakeElementAt (qTyIsIQueryable qTy, srcItemTy, source, MacroExpand valCountExpr) + | CallNth (_, [srcItemTy; qTy], source, valCountExpr) -> + let source = TransInnerWithFinalConsume CanEliminate.Yes source + MakeElementAt (qTyIsIQueryable qTy, srcItemTy, source, MacroExpand valCountExpr) - | LetExprReduction reduced -> TransNestedOuter canElim reduced - | MacroReduction reduced -> TransNestedOuter canElim reduced + | LetExprReduction reduced -> + TransNestedOuter canElim reduced + + | MacroReduction reduced -> + TransNestedOuter canElim reduced + + | source -> + TransInnerWithFinalConsume canElim source - | source -> - TransInnerWithFinalConsume canElim source - // Nested queries appear as query { .... } // [[ query { ... } ]] = TransNestedOuter canElim[[q]] // -- This is the primary translation for nested sequences. - let EliminateNestedQueries q = - q |> RewriteExpr (fun walk p -> - match p with - | AnyNestedQuery e -> Some (walk (TransNestedOuter CanEliminate.No e)) + let EliminateNestedQueries q = + q |> RewriteExpr (fun walk p -> + match p with + | AnyNestedQuery e -> Some (walk (TransNestedOuter CanEliminate.No e)) | _ -> None) - + /// Evaluate the inner core of a query that actually produces a sequence of results. /// Do this by converting to an expression tree for a LINQ query and evaluating that. - let EvalNonNestedInner canElim (queryProducingSequence:Expr) = + let EvalNonNestedInner canElim (queryProducingSequence:Expr) = let linqQuery = TransInnerWithFinalConsume canElim queryProducingSequence - let linqQueryAfterEliminatingNestedQueries = EliminateNestedQueries linqQuery + let linqQueryAfterEliminatingNestedQueries = EliminateNestedQueries linqQuery #if !FX_NO_SYSTEM_CONSOLE #if DEBUG - let debug() = - Printf.printfn "----------------------queryProducingSequence-------------------------" + let debug() = + Printf.printfn "----------------------queryProducingSequence-------------------------" Printf.printfn "%A" queryProducingSequence - Printf.printfn "--------------------------linqQuery (before nested)------------------" - Printf.printfn "%A" linqQuery - Printf.printfn "--------------------------linqQuery (after nested)-------------------" - Printf.printfn "%A" linqQueryAfterEliminatingNestedQueries + Printf.printfn "--------------------------linqQuery (before nested)------------------" + Printf.printfn "%A" linqQuery + Printf.printfn "--------------------------linqQuery (after nested)-------------------" + Printf.printfn "%A" linqQueryAfterEliminatingNestedQueries #endif #endif - let result = - try + let result = + try LeafExpressionConverter.EvaluateQuotation linqQueryAfterEliminatingNestedQueries - with e -> + with e -> #if !FX_NO_SYSTEM_CONSOLE #if DEBUG debug() - Printf.printfn "--------------------------error--------------------------------------" + Printf.printfn "--------------------------error--------------------------------------" Printf.printfn "%A" (e.ToString()) - Printf.printfn "---------------------------------------------------------------------" + Printf.printfn "---------------------------------------------------------------------" #endif #endif reraise () @@ -1689,37 +1835,99 @@ module Query = result /// Evaluate the outer calls of a query until the inner core that actually produces a sequence of results is reached. - let rec EvalNonNestedOuter canElim (tm:Expr) = + let rec EvalNonNestedOuter canElim (tm:Expr) = match tm with - - | CallMinBy (_, [srcItemTy; qTy; keyItemTy], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallMinBy (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, keyItemTy, v, MacroExpand valSelector) - | CallMaxBy (_, [srcItemTy; qTy; keyItemTy], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallMaxBy (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, keyItemTy, v, MacroExpand valSelector) - | CallMinByNullable (_, [srcItemTy; qTy; keyItemTy ], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallMinByNullable (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, MakeNullableTy keyItemTy, v, MacroExpand valSelector) - | CallMaxByNullable (_, [srcItemTy; qTy; keyItemTy ], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallMaxByNullable (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, MakeNullableTy keyItemTy, v, MacroExpand valSelector) - | CallCount (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallCount (qTyIsIQueryable qTy, srcItemTy, sourcev) - | CallHead (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallFirst (qTyIsIQueryable qTy, srcItemTy, sourcev) - | CallLast (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallLast (qTyIsIQueryable qTy, srcItemTy, sourcev) - | CallHeadOrDefault (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallFirstOrDefault (qTyIsIQueryable qTy, srcItemTy, sourcev) - | CallLastOrDefault (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallLastOrDefault (qTyIsIQueryable qTy, srcItemTy, sourcev) - | CallExactlyOne (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallSingle (qTyIsIQueryable qTy, srcItemTy, sourcev) - | CallExactlyOneOrDefault (_, [srcItemTy; qTy], source) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallSingleOrDefault(qTyIsIQueryable qTy, srcItemTy, sourcev) - - | CallAverageBy (qb, [srcItemTy; qTy; resTy], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallAverageBy (qb, qTyIsIQueryable qTy, srcItemTy, resTy, sourcev, resTy, v, MacroExpand valSelector) - | CallAverageByNullable (qb, [srcItemTy; qTy; resTyNoNullable], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallAverageByNullable(qb, qTyIsIQueryable qTy, srcItemTy, resTyNoNullable, sourcev, MakeNullableTy resTyNoNullable, v, MacroExpand valSelector) - | CallSumBy (qb, [srcItemTy; qTy; resTy], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallSumBy (qb, qTyIsIQueryable qTy, srcItemTy, resTy, sourcev, resTy, v, MacroExpand valSelector) - | CallSumByNullable (qb, [srcItemTy; qTy; resTyNoNullable], source, Lambda(v, valSelector)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallSumByNullable (qb, qTyIsIQueryable qTy, srcItemTy, resTyNoNullable, sourcev, MakeNullableTy resTyNoNullable, v, MacroExpand valSelector) - | CallExists (_, [srcItemTy; qTy], source, Lambda(v, predicate)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallAny (qTyIsIQueryable qTy, srcItemTy, sourcev, v, MacroExpand predicate) - | CallForAll (_, [srcItemTy; qTy], source, Lambda(v, predicate)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallAll (qTyIsIQueryable qTy, srcItemTy, sourcev, v, MacroExpand predicate) - | CallFind (_, [srcItemTy; qTy], source, Lambda(v, f)) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallFirstFind (qTyIsIQueryable qTy, srcItemTy, sourcev, v, MacroExpand f) - | CallContains (_, [srcItemTy; qTy], source, v) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallContains (qTyIsIQueryable qTy, srcItemTy, sourcev, MacroExpand v) - | CallNth (_, [srcItemTy; qTy], source, v) -> let sourcev = EvalNonNestedInner CanEliminate.Yes source in CallElementAt (qTyIsIQueryable qTy, srcItemTy, sourcev, MacroExpand v) - - | LetExprReduction reduced -> EvalNonNestedOuter canElim reduced - | MacroReduction reduced -> EvalNonNestedOuter canElim reduced - - | source -> EvalNonNestedInner canElim source - - let QueryExecute (p : Expr<'T>) : 'U = + + | CallMinBy (_, [srcItemTy; qTy; keyItemTy], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallMinBy (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, keyItemTy, v, MacroExpand valSelector) + + | CallMaxBy (_, [srcItemTy; qTy; keyItemTy], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallMaxBy (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, keyItemTy, v, MacroExpand valSelector) + + | CallMinByNullable (_, [srcItemTy; qTy; keyItemTy ], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallMinByNullable (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, MakeNullableTy keyItemTy, v, MacroExpand valSelector) + + | CallMaxByNullable (_, [srcItemTy; qTy; keyItemTy ], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallMaxByNullable (qTyIsIQueryable qTy, srcItemTy, keyItemTy, sourcev, MakeNullableTy keyItemTy, v, MacroExpand valSelector) + + | CallCount (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallCount (qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallHead (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallFirst (qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallLast (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallLast (qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallHeadOrDefault (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallFirstOrDefault (qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallLastOrDefault (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallLastOrDefault (qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallExactlyOne (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallSingle (qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallExactlyOneOrDefault (_, [srcItemTy; qTy], source) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallSingleOrDefault(qTyIsIQueryable qTy, srcItemTy, sourcev) + + | CallAverageBy (qb, [srcItemTy; qTy; resTy], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallAverageBy (qb, qTyIsIQueryable qTy, srcItemTy, resTy, sourcev, resTy, v, MacroExpand valSelector) + + | CallAverageByNullable (qb, [srcItemTy; qTy; resTyNoNullable], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallAverageByNullable(qb, qTyIsIQueryable qTy, srcItemTy, resTyNoNullable, sourcev, MakeNullableTy resTyNoNullable, v, MacroExpand valSelector) + + | CallSumBy (qb, [srcItemTy; qTy; resTy], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallSumBy (qb, qTyIsIQueryable qTy, srcItemTy, resTy, sourcev, resTy, v, MacroExpand valSelector) + + | CallSumByNullable (qb, [srcItemTy; qTy; resTyNoNullable], source, Lambda(v, valSelector)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallSumByNullable (qb, qTyIsIQueryable qTy, srcItemTy, resTyNoNullable, sourcev, MakeNullableTy resTyNoNullable, v, MacroExpand valSelector) + + | CallExists (_, [srcItemTy; qTy], source, Lambda(v, predicate)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallAny (qTyIsIQueryable qTy, srcItemTy, sourcev, v, MacroExpand predicate) + + | CallForAll (_, [srcItemTy; qTy], source, Lambda(v, predicate)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallAll (qTyIsIQueryable qTy, srcItemTy, sourcev, v, MacroExpand predicate) + + | CallFind (_, [srcItemTy; qTy], source, Lambda(v, f)) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallFirstFind (qTyIsIQueryable qTy, srcItemTy, sourcev, v, MacroExpand f) + + | CallContains (_, [srcItemTy; qTy], source, v) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallContains (qTyIsIQueryable qTy, srcItemTy, sourcev, MacroExpand v) + + | CallNth (_, [srcItemTy; qTy], source, v) -> + let sourcev = EvalNonNestedInner CanEliminate.Yes source + CallElementAt (qTyIsIQueryable qTy, srcItemTy, sourcev, MacroExpand v) + + | LetExprReduction reduced -> + EvalNonNestedOuter canElim reduced + + | MacroReduction reduced -> + EvalNonNestedOuter canElim reduced + + | source -> + EvalNonNestedInner canElim source + + let QueryExecute (p: Expr<'T>) : 'U = // We use Unchecked.unbox to allow headOrDefault, lastOrDefault and exactlyOneOrDefault to return Unchecked.defaultof<_> values for F# types Unchecked.unbox (EvalNonNestedOuter CanEliminate.No p) @@ -1729,5 +1937,5 @@ module Query = member this.Execute(q) = QueryExecute q member this.EliminateNestedQueries(e) = EliminateNestedQueries e } - + diff --git a/src/fsharp/FSharp.Core/array.fs b/src/fsharp/FSharp.Core/array.fs index 13c3353ca06..c56879873c4 100644 --- a/src/fsharp/FSharp.Core/array.fs +++ b/src/fsharp/FSharp.Core/array.fs @@ -30,13 +30,13 @@ namespace Microsoft.FSharp.Collections let length (array: _[]) = array.Length [] - let inline last (array : 'T[]) = + let inline last (array: 'T[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString array.[array.Length-1] [] - let tryLast (array : 'T[]) = + let tryLast (array: 'T[]) = checkNonNull "array" array if array.Length = 0 then None else Some array.[array.Length-1] @@ -50,7 +50,7 @@ namespace Microsoft.FSharp.Collections Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count [] - let create (count:int) (value:'T) = + let create (count: int) (value: 'T) = 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 @@ -58,7 +58,7 @@ namespace Microsoft.FSharp.Collections array [] - let tryHead (array : 'T[]) = + let tryHead (array: 'T[]) = checkNonNull "array" array if array.Length = 0 then None else Some array.[0] @@ -69,7 +69,7 @@ namespace Microsoft.FSharp.Collections (array.Length = 0) [] - let tail (array : 'T[]) = + let tail (array: 'T[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" (SR.GetString(SR.notEnoughElements)) Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 1 (array.Length - 1) array @@ -77,12 +77,12 @@ namespace Microsoft.FSharp.Collections [] 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 concatArrays (arrs: 'T[][]) : 'T[] = let mutable acc = 0 for h in arrs do acc <- acc + h.Length @@ -93,7 +93,7 @@ namespace Microsoft.FSharp.Collections for i = 0 to arrs.Length-1 do let h = arrs.[i] let len = h.Length - Array.Copy(h,0,res,j,len) + Array.Copy(h, 0, res, j, len) j <- j + len res @@ -107,13 +107,13 @@ namespace Microsoft.FSharp.Collections [] let replicate count initial = if count < 0 then invalidArgInputMustBeNonNegative "count" count - let arr : 'T array = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 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 @@ -122,24 +122,24 @@ namespace Microsoft.FSharp.Collections concatArrays result [] - let splitAt index (array:'T[]) = + 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 let right = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 array.Length array - [||],right + [||], right elif index = array.Length then let left = Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 array.Length array - left,[||] + 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 - res1,res2 + res1, res2 [] - let take count (array : 'T[]) = + let take count (array: 'T[]) = checkNonNull "array" array if count < 0 then invalidArgInputMustBeNonNegative "count" count if count = 0 then @@ -162,7 +162,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -182,13 +182,15 @@ namespace Microsoft.FSharp.Collections 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[]) = countByImpl HashIdentity.Structural<'Key> projection id array + let countByValueType (projection: 'T -> 'Key) (array: 'T[]) = + countByImpl HashIdentity.Structural<'Key> projection id 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 + let countByRefType (projection: 'T -> 'Key) (array: 'T[]) = + 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 FX_RESHAPED_REFLECTION if (typeof<'Key>).GetTypeInfo().IsValueType @@ -199,18 +201,18 @@ namespace Microsoft.FSharp.Collections 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 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 [] - let head (array : 'T[]) = + let head (array: 'T[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString else array.[0] @@ -239,7 +241,7 @@ namespace Microsoft.FSharp.Collections checkNonNull "array" array let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length for i = 0 to res.Length-1 do - res.[i] <- (i,array.[i]) + res.[i] <- (i, array.[i]) res [] @@ -249,7 +251,7 @@ namespace Microsoft.FSharp.Collections action array.[i] [] - let distinct (array:'T[]) = + let distinct (array: 'T[]) = checkNonNull "array" array let temp = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length let mutable i = 0 @@ -263,9 +265,9 @@ namespace Microsoft.FSharp.Collections Microsoft.FSharp.Primitives.Basics.Array.subUnchecked 0 i temp [] - let inline map (mapping: 'T -> 'U) (array:'T[]) = + let inline map (mapping: 'T -> 'U) (array: 'T[]) = checkNonNull "array" array - let res : 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked array.Length + 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 @@ -274,13 +276,13 @@ namespace Microsoft.FSharp.Collections let iter2 action (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) + 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[]) = + let distinctBy projection (array: 'T[]) = checkNonNull "array" array let length = array.Length if length = 0 then Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked 0 else @@ -299,7 +301,7 @@ namespace Microsoft.FSharp.Collections let map2 mapping (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(mapping) + 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 @@ -311,7 +313,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -324,17 +326,17 @@ namespace Microsoft.FSharp.Collections let mapi2 mapping (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(mapping) + 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.[i] <- f.Invoke(i, array1.[i], array2.[i]) res [] - let iteri action (array:'T[]) = + let iteri action (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) for i = 0 to array.Length-1 do f.Invoke(i, array.[i]) @@ -342,39 +344,39 @@ namespace Microsoft.FSharp.Collections let iteri2 action (array1: 'T[]) (array2: 'U[]) = checkNonNull "array1" array1 checkNonNull "array2" array2 - let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(action) + 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]) + f.Invoke(i, array1.[i], array2.[i]) [] - let mapi (mapping : int -> 'T -> 'U) (array: 'T[]) = + 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 - res.[i] <- f.Invoke(i,array.[i]) + res.[i] <- f.Invoke(i, array.[i]) res [] - let mapFold<'T,'State,'Result> (mapping : 'State -> 'T -> 'Result * 'State) state array = + let mapFold<'T, 'State, 'Result> (mapping: 'State -> 'T -> 'Result * 'State) state array = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.mapFold mapping state array [] - let mapFoldBack<'T,'State,'Result> (mapping : 'T -> 'State -> 'Result * 'State) array state = + let mapFoldBack<'T, 'State, 'Result> (mapping: 'T -> 'State -> 'Result * 'State) array state = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.mapFoldBack mapping array state [] - let exists (predicate: 'T -> bool) (array:'T[]) = + let exists (predicate: 'T -> bool) (array: 'T[]) = checkNonNull "array" array let len = array.Length let rec loop i = i < len && (predicate array.[i] || loop (i+1)) len > 0 && loop 0 [] - let inline contains value (array:'T[]) = + let inline contains value (array: 'T[]) = checkNonNull "array" array let mutable state = false let mutable i = 0 @@ -387,14 +389,14 @@ namespace Microsoft.FSharp.Collections 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)) loop 0 [] - let forall (predicate: 'T -> bool) (array:'T[]) = + 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)) @@ -404,16 +406,16 @@ namespace Microsoft.FSharp.Collections 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)) 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 + let dict = Dictionary<_, ResizeArray<_>> comparer // Build the groupings for i = 0 to length - 1 do @@ -437,13 +439,13 @@ namespace Microsoft.FSharp.Collections 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 FX_RESHAPED_REFLECTION if (typeof<'Key>).GetTypeInfo().IsValueType @@ -490,7 +492,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -503,7 +505,7 @@ namespace Microsoft.FSharp.Collections i <- i + 1 if i < array.Length then - let chunk2 : 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (array.Length-i) + let chunk2: 'U[] = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (array.Length-i) count <- 0 while i < array.Length do let element = array.[i] @@ -513,9 +515,9 @@ namespace Microsoft.FSharp.Collections count <- count + 1 i <- i + 1 - 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) + 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 @@ -526,12 +528,12 @@ namespace Microsoft.FSharp.Collections // 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 let srcIdx = maskIdx * 32 @@ -571,7 +573,7 @@ namespace Microsoft.FSharp.Collections maskArray.[maskIdx] <- mask count - let private createMask<'a> (f:'a->bool) (src:array<'a>) (maskArrayOut:byref>) (leftoverMaskOut:byref) = + 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. @@ -599,7 +601,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -657,7 +659,7 @@ namespace Microsoft.FSharp.Collections dstIdx - let private filterViaMask (maskArray:array) (leftoverMask:uint32) (count:int) (src:array<_>) = + let private filterViaMask (maskArray: array) (leftoverMask: uint32) (count: int) (src: array<_>) = let dst = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked count let mutable dstIdx = 0 @@ -675,7 +677,7 @@ namespace Microsoft.FSharp.Collections dst - let filter f (src:array<_>) = + let filter f (src: array<_>) = let mutable maskArray = Unchecked.defaultof<_> let mutable leftOverMask = Unchecked.defaultof<_> match createMask f src &maskArray &leftOverMask with @@ -691,7 +693,7 @@ namespace Microsoft.FSharp.Collections let where predicate (array: _[]) = filter predicate array [] - let except (itemsToExclude: seq<_>) (array:_[]) = + let except (itemsToExclude: seq<_>) (array: _[]) = checkNonNull "itemsToExclude" itemsToExclude checkNonNull "array" array @@ -742,7 +744,7 @@ namespace Microsoft.FSharp.Collections loop 0 [] - let skip count (array:'T[]) = + 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 @@ -772,30 +774,30 @@ namespace Microsoft.FSharp.Collections Microsoft.FSharp.Primitives.Basics.Array.tryFindBack predicate array [] - let findIndexBack predicate (array : _[]) = + let findIndexBack predicate (array: _[]) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.findIndexBack predicate array [] - let tryFindIndexBack predicate (array : _[]) = + let tryFindIndexBack predicate (array: _[]) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.tryFindIndexBack predicate array [] - let windowed windowSize (array:'T[]) = + let windowed windowSize (array: 'T[]) = checkNonNull "array" array 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[]) = + let chunkBySize chunkSize (array: 'T[]) = checkNonNull "array" array if chunkSize <= 0 then invalidArgInputMustBePositive "chunkSize" chunkSize let len = array.Length @@ -805,7 +807,7 @@ namespace Microsoft.FSharp.Collections [| copy array |] else let chunkCount = (len - 1) / chunkSize + 1 - let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked chunkCount : 'T[][] + let res = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked chunkCount: 'T[][] 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 @@ -813,7 +815,7 @@ namespace Microsoft.FSharp.Collections res [] - let splitInto count (array:_[]) = + let splitInto count (array: _[]) = checkNonNull "array" array if count <= 0 then invalidArgInputMustBePositive "count" count Microsoft.FSharp.Primitives.Basics.Array.splitInto count array @@ -826,7 +828,7 @@ namespace Microsoft.FSharp.Collections 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.[i] <- (array1.[i], array2.[i]) res [] @@ -838,7 +840,7 @@ namespace Microsoft.FSharp.Collections 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.[i] <- (array1.[i], array2.[i], array3.[i]) res [] @@ -850,16 +852,16 @@ namespace Microsoft.FSharp.Collections 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 - res.[i * len2 + j] <- (array1.[i],array2.[j]) + 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') -> + | Some (x, s') -> res.Add(x) loop s' loop state @@ -872,10 +874,10 @@ namespace Microsoft.FSharp.Collections 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 x, y = array.[i] res1.[i] <- x res2.[i] <- y - res1,res2 + res1, res2 [] let unzip3 (array: _[]) = @@ -885,11 +887,11 @@ namespace Microsoft.FSharp.Collections 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 x, y, z = array.[i] res1.[i] <- x res2.[i] <- y res3.[i] <- z - res1,res2,res3 + res1, res2, res3 [] let rev (array: _[]) = @@ -902,74 +904,74 @@ namespace Microsoft.FSharp.Collections res [] - let fold<'T,'State> (folder : 'State -> 'T -> 'State) (state: 'State) (array:'T[]) = + 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 - state <- f.Invoke(state,array.[i]) + state <- f.Invoke(state, array.[i]) state [] - let foldBack<'T,'State> (folder : 'T -> 'State -> 'State) (array:'T[]) (state: '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 - res <- f.Invoke(array.[i],res) + 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 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 - res <- f.Invoke(array1.[i],array2.[i],res) + 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 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 <- 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 f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) let mutable res = acc for i = fin downto start do - res <- f.Invoke(array.[i],res) + 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 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]) + state <- f.Invoke(state, array.[i]) 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 @@ -980,30 +982,30 @@ namespace Microsoft.FSharp.Collections 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]) + 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 invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString else - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(reduction) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(reduction) let mutable res = array.[0] for i = 1 to array.Length-1 do - res <- f.Invoke(res,array.[i]) + 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] [] - let sortInPlaceWith comparer (array : 'T[]) = + let sortInPlaceWith comparer (array: 'T[]) = checkNonNull "array" array let len = array.Length if len < 2 then () @@ -1017,17 +1019,17 @@ namespace Microsoft.FSharp.Collections 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 [] - let sortWith (comparer: 'T -> 'T -> int) (array : 'T[]) = + let sortWith (comparer: 'T -> 'T -> int) (array: 'T[]) = checkNonNull "array" array let result = copy array sortInPlaceWith comparer result @@ -1070,7 +1072,7 @@ namespace Microsoft.FSharp.Collections Seq.toArray source [] - let findIndex predicate (array : _[]) = + let findIndex predicate (array: _[]) = checkNonNull "array" array let len = array.Length let rec go n = @@ -1082,14 +1084,14 @@ namespace Microsoft.FSharp.Collections 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 permute indexMap (array : _[]) = + let permute indexMap (array: _[]) = checkNonNull "array" array Microsoft.FSharp.Primitives.Basics.Array.permute indexMap array @@ -1102,7 +1104,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -1110,7 +1112,7 @@ namespace Microsoft.FSharp.Collections acc [] - let inline min (array:_[]) = + let inline min (array: _[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString let mutable acc = array.[0] @@ -1121,7 +1123,7 @@ namespace Microsoft.FSharp.Collections acc [] - let inline minBy projection (array:_[]) = + let inline minBy projection (array: _[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString let mutable accv = array.[0] @@ -1135,7 +1137,7 @@ namespace Microsoft.FSharp.Collections accv [] - let inline max (array:_[]) = + let inline max (array: _[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString let mutable acc = array.[0] @@ -1146,7 +1148,7 @@ namespace Microsoft.FSharp.Collections acc [] - let inline maxBy projection (array:_[]) = + let inline maxBy projection (array: _[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString let mutable accv = array.[0] @@ -1160,7 +1162,7 @@ namespace Microsoft.FSharp.Collections accv [] - let inline average (array:'T[]) = + let inline average (array: 'T[]) = checkNonNull "array" array if array.Length = 0 then invalidArg "array" LanguagePrimitives.ErrorStrings.InputArrayEmptyString let mutable acc = LanguagePrimitives.GenericZero< ^T> @@ -1169,7 +1171,7 @@ namespace Microsoft.FSharp.Collections 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 let mutable acc = LanguagePrimitives.GenericZero< ^U> @@ -1178,7 +1180,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -1203,7 +1205,7 @@ namespace Microsoft.FSharp.Collections else 1 [] - let sub (array:'T[]) (startIndex:int) (count:int) = + 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 @@ -1211,25 +1213,25 @@ namespace Microsoft.FSharp.Collections Microsoft.FSharp.Primitives.Basics.Array.subUnchecked startIndex count array [] - let item index (array:_[]) = + let item index (array: _[]) = array.[index] [] - let tryItem index (array:'T[]) = + let tryItem index (array: 'T[]) = checkNonNull "array" array 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) = + 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 @@ -1237,19 +1239,19 @@ namespace Microsoft.FSharp.Collections target.[i] <- value [] - let exactlyOne (array:'T[]) = + 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)) [] - let tryExactlyOne (array:'T[]) = + let tryExactlyOne (array: 'T[]) = checkNonNull "array" array if array.Length = 1 then Some array.[0] else None - let transposeArrays (array:'T[][]) = + 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 @@ -1258,7 +1260,7 @@ namespace Microsoft.FSharp.Collections 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 + 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 @@ -1266,14 +1268,14 @@ namespace Microsoft.FSharp.Collections result [] - let transpose (arrays:seq<'T[]>) = + 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 [] - let truncate count (array:'T[]) = + let truncate count (array: 'T[]) = checkNonNull "array" array if count <= 0 then empty else @@ -1289,20 +1291,20 @@ namespace Microsoft.FSharp.Collections 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 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 () ->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 ) + count+1), + Action (fun x -> System.Threading.Interlocked.Add(&outputLength, x) |> ignore ) ) |> ignore let output = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked outputLength @@ -1314,7 +1316,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -1323,7 +1325,7 @@ namespace Microsoft.FSharp.Collections 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 @@ -1334,7 +1336,7 @@ namespace Microsoft.FSharp.Collections [] 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 -> @@ -1342,14 +1344,14 @@ namespace Microsoft.FSharp.Collections result [] - let iter action (array : 'T[]) = + let iter action (array: 'T[]) = checkNonNull "array" array Parallel.For (0, array.Length, fun i -> action array.[i]) |> ignore [] - let iteri action (array : 'T[]) = + let iteri action (array: 'T[]) = checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) Parallel.For (0, array.Length, fun i -> f.Invoke(i, array.[i])) |> ignore [] @@ -1359,7 +1361,7 @@ namespace Microsoft.FSharp.Collections result [] - let partition predicate (array : 'T[]) = + let partition predicate (array: 'T[]) = checkNonNull "array" array let inputLength = array.Length @@ -1367,14 +1369,14 @@ namespace Microsoft.FSharp.Collections let mutable trueLength = 0 Parallel.For(0, inputLength, - (fun () -> 0), + (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 + 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) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index 4fe2d48d6fc..0e94edde2af 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -714,7 +714,7 @@ namespace Microsoft.FSharp.Control member x.GetWaitHandle() = lock syncRoot (fun () -> if disposed then - raise (System.ObjectDisposedException("ResultCell")); + raise (System.ObjectDisposedException("ResultCell")) match resEvent with | null -> // Start in signalled state if a result is already present. @@ -727,7 +727,7 @@ namespace Microsoft.FSharp.Control member x.Close() = lock syncRoot (fun () -> if not disposed then - disposed <- true; + disposed <- true match resEvent with | null -> () | ev -> @@ -735,7 +735,7 @@ namespace Microsoft.FSharp.Control ev.Dispose() System.GC.SuppressFinalize(ev) #else - ev.Close(); + ev.Close() #endif resEvent <- null) @@ -760,7 +760,7 @@ namespace Microsoft.FSharp.Control if disposed then [] else - result <- Some res; + 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 @@ -1426,7 +1426,7 @@ namespace Microsoft.FSharp.Control ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> savedCont (not timeOut)) |> unfake), state=null, millisecondsTimeOutInterval=millisecondsTimeout, - executeOnlyOnce=true)); + executeOnlyOnce=true)) fake()) with _ -> if latch.Enter() then diff --git a/src/fsharp/FSharp.Core/eventmodule.fs b/src/fsharp/FSharp.Core/eventmodule.fs index da359843d5c..1d615a307c3 100644 --- a/src/fsharp/FSharp.Core/eventmodule.fs +++ b/src/fsharp/FSharp.Core/eventmodule.fs @@ -16,26 +16,26 @@ namespace Microsoft.FSharp.Control [] let map mapping (sourceEvent: IEvent<'Delegate,'T>) = let ev = new Event<_>() - sourceEvent.Add(fun x -> ev.Trigger(mapping x)); + sourceEvent.Add(fun x -> ev.Trigger(mapping x)) ev.Publish [] let filter predicate (sourceEvent: IEvent<'Delegate,'T>) = let ev = new Event<_>() - sourceEvent.Add(fun x -> if predicate x then ev.Trigger x); + 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); + 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); + sourceEvent.Add(fun x -> match chooser x with None -> () | Some r -> ev.Trigger r) ev.Publish [] @@ -46,7 +46,7 @@ namespace Microsoft.FSharp.Control let z = !state let z = collector z msg state := z; - ev.Trigger(z)); + ev.Trigger(z)) ev.Publish [] @@ -75,7 +75,7 @@ namespace Microsoft.FSharp.Control 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)); + 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/FSharp.Core/fslib-extra-pervasives.fs b/src/fsharp/FSharp.Core/fslib-extra-pervasives.fs index b4271f4a267..dd8d087345e 100644 --- a/src/fsharp/FSharp.Core/fslib-extra-pervasives.fs +++ b/src/fsharp/FSharp.Core/fslib-extra-pervasives.fs @@ -56,9 +56,9 @@ module ExtraTopLevelOperators = member s.Keys = let keys = t.Keys { new ICollection<'Key> with - member s.Add(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))); - member s.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))); - member s.Remove(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))); + member s.Add(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member s.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member s.Remove(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) member s.Contains(x) = t.ContainsKey (makeSafeKey x) member s.CopyTo(arr,i) = let mutable n = 0 @@ -93,9 +93,9 @@ module ExtraTopLevelOperators = member __.ContainsKey k = t.ContainsKey (makeSafeKey k) interface ICollection> with - member s.Add(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))); - member s.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))); - member s.Remove(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))); + member s.Add(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member s.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + member s.Remove(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) member s.Contains(KeyValue(k,v)) = ICollection_Contains t (KeyValuePair<_,_>(makeSafeKey k,v)) member s.CopyTo(arr,i) = let mutable n = 0 @@ -204,11 +204,11 @@ module ExtraTopLevelOperators = 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] + 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] res // -------------------------------------------------------------------- @@ -285,7 +285,6 @@ module ExtraTopLevelOperators = [] let (|Lazy|) (input:Lazy<_>) = input.Force() - let query = Microsoft.FSharp.Linq.QueryBuilder() @@ -297,7 +296,6 @@ namespace Microsoft.FSharp.Core.CompilerServices open System.Collections.Generic open Microsoft.FSharp.Core - /// Represents the product of two measure expressions when returned as a generic argument of a provided type. [] type MeasureProduct<'Measure1, 'Measure2>() = class end diff --git a/src/fsharp/FSharp.Core/list.fs b/src/fsharp/FSharp.Core/list.fs index 6092567f1f4..9a7233228ad 100644 --- a/src/fsharp/FSharp.Core/list.fs +++ b/src/fsharp/FSharp.Core/list.fs @@ -15,7 +15,7 @@ namespace Microsoft.FSharp.Collections [] [] - module List = + module List = let inline checkNonNull argName arg = match box arg with @@ -26,9 +26,9 @@ namespace Microsoft.FSharp.Collections [] let length (list: 'T list) = list.Length - + [] - let rec last (list : 'T list) = + let rec last (list: 'T list) = match list with | [x] -> x | _ :: tail -> last tail @@ -56,7 +56,7 @@ namespace Microsoft.FSharp.Collections let rec loop srcList = match srcList with | [] -> () - | h::t -> + | h :: t -> let safeKey = projection h let mutable prev = 0 if dict.TryGetValue(safeKey, &prev) then dict.[safeKey] <- prev + 1 else dict.[safeKey] <- 1 @@ -90,27 +90,27 @@ namespace Microsoft.FSharp.Collections 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 = + 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 + | h :: t, (list', acc') -> + let h', s' = f.Invoke(h, acc') + loop (h' :: list', s') t loop ([], state) (rev list) [] let iter action list = Microsoft.FSharp.Primitives.Basics.List.iter action list - + [] let distinct (list:'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctWithComparer HashIdentity.Structural<'T> list @@ -127,24 +127,24 @@ namespace Microsoft.FSharp.Collections 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 append list1 list2 = list1 @ list2 [] let rec item index list = match list with - | h::t when index >= 0 -> + | h :: t when index >= 0 -> if index = 0 then h else item (index - 1) t | _ -> invalidArg "index" (SR.GetString(SR.indexOutOfBounds)) @@ -152,7 +152,7 @@ namespace Microsoft.FSharp.Collections [] let rec tryItem index list = match list with - | h::t when index >= 0 -> + | h :: t when index >= 0 -> if index = 0 then Some h else tryItem (index - 1) t | _ -> None @@ -162,12 +162,12 @@ namespace Microsoft.FSharp.Collections [] 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 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 @@ -178,53 +178,53 @@ namespace Microsoft.FSharp.Collections [] let init length initializer = Microsoft.FSharp.Primitives.Basics.List.init length initializer - let rec initConstAcc n x acc = - if n <= 0 then acc else initConstAcc (n-1) x (x::acc) - + let rec initConstAcc n x acc = + if n <= 0 then acc else initConstAcc (n-1) x (x :: acc) + [] - let replicate count initial = + let replicate count initial = if count < 0 then invalidArg "count" (SR.GetString(SR.inputMustBeNonNegative)) - initConstAcc count initial [] + initConstAcc count initial [] [] - let iter2 action list1 list2 = - 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 - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + let iter2 action list1 list2 = + 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 + | [], 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 rec loop n list1 list2 = - match list1,list2 with - | [],[] -> () - | 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 + let iteri2 action list1 list2 = + 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 + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length loop 0 list1 list2 [] - let map3 mapping list1 list2 list3 = + let map3 mapping list1 list2 list3 = Microsoft.FSharp.Primitives.Basics.List.map3 mapping list1 list2 list3 [] - let mapi2 mapping list1 list2 = + let mapi2 mapping list1 list2 = Microsoft.FSharp.Primitives.Basics.List.mapi2 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) = - match list with + 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) @@ -235,126 +235,126 @@ namespace Microsoft.FSharp.Collections Microsoft.FSharp.Primitives.Basics.List.pairwise list [] - let reduce reduction list = - match list with + let reduce reduction list = + match list with | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) - | h::t -> fold reduction h t + | 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 fold2<'T1,'T2,'State> folder (state:'State) (list1:list<'T1>) (list2:list<'T2>) = - let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(folder) + let fold2<'T1, 'T2, 'State> folder (state:'State) (list1:list<'T1>) (list2:list<'T2>) = + 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 + 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 + // 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) - match list with + 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)))) - | _ -> - // 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. + | [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. let arr = toArray list let arrn = arr.Length foldArraySubRight f arr 0 (arrn - 1) state [] - let reduceBack reduction list = - match list with + let reduceBack reduction 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] for i = fin downto start do - state <- f.Invoke(arr.[i], state); + state <- f.Invoke(arr.[i], state) res <- state :: res res [] - let scanBack<'T,'State> folder (list:'T list) (state:'State) = - match list with + let scanBack<'T, 'State> folder (list:'T list) (state:'State) = + match list with | [] -> [state] - | [h] -> + | [h] -> [folder h state; state] - | _ -> - 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 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" + if n1 <> n2 then + invalidArgFmt "list1, list2" "{0}\nlist1.Length = {1}, list2.Length = {2}" [|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 <- f.Invoke(arr1.[i], arr2.[i], res) res [] - 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) - 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)))) + 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) + 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)))) | _ -> foldBack2UsingArrays f list1 list2 state - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - 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 - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + 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 + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length [] - let forall2 predicate list1 list2 = - match list1,list2 with - | [],[] -> true - | _ -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(predicate) + let forall2 predicate list1 list2 = + match list1, list2 with + | [], [] -> true + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) forall2aux f list1 list2 [] @@ -362,34 +362,34 @@ namespace Microsoft.FSharp.Collections [] let exists predicate list = Microsoft.FSharp.Primitives.Basics.List.exists predicate list - + [] let inline contains value source = let rec contains e xs1 = match xs1 with | [] -> false - | h1::t1 -> e = h1 || contains e t1 + | h1 :: t1 -> e = h1 || contains e t1 contains value source - 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 + 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 | _ -> invalidArg "list2" (SR.GetString(SR.listsHadDifferentLengths)) [] - let rec exists2 predicate list1 list2 = - match list1,list2 with - | [],[] -> false - | _ -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(predicate) + let rec exists2 predicate list1 list2 = + match list1, list2 with + | [], [] -> false + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) exists2aux f list1 list2 [] - let rec find predicate list = match list with [] -> indexNotFound() | h::t -> if predicate h then h else find predicate t + let rec find predicate list = match list with [] -> 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 + let rec tryFind predicate list = match list with [] -> 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 @@ -398,21 +398,21 @@ namespace Microsoft.FSharp.Collections let tryFindBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.tryFindBack predicate [] - let rec tryPick chooser list = - match list with - | [] -> None - | h::t -> - match chooser h with - | None -> tryPick chooser t + let rec tryPick chooser list = + match list with + | [] -> None + | h :: t -> + match chooser h with + | None -> tryPick chooser t | r -> r [] - let rec pick chooser list = - match list with + let rec pick chooser list = + match list with | [] -> indexNotFound() - | h::t -> - match chooser h with - | None -> pick chooser t + | h :: t -> + match chooser h with + | None -> pick chooser t | Some r -> r [] @@ -451,7 +451,7 @@ namespace Microsoft.FSharp.Collections [] let partition predicate list = Microsoft.FSharp.Primitives.Basics.List.partition predicate list - + [] let unzip list = Microsoft.FSharp.Primitives.Basics.List.unzip list @@ -479,7 +479,7 @@ namespace Microsoft.FSharp.Collections let rec loop i lst = match lst with | _ when i = 0 -> lst - | _::t -> loop (i-1) t + | _ :: t -> loop (i-1) t | [] -> invalidArgOutOfRange "count" count "distance past the list" i loop count list @@ -500,18 +500,18 @@ namespace Microsoft.FSharp.Collections [] let sortBy projection list = - match list with + match list with | [] | [_] -> list - | _ -> + | _ -> let array = Microsoft.FSharp.Primitives.Basics.List.toArray list Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceBy projection array Microsoft.FSharp.Primitives.Basics.List.ofArray array - + [] let sort list = - match list with + match list with | [] | [_] -> list - | _ -> + | _ -> let array = Microsoft.FSharp.Primitives.Basics.List.toArray list Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlace array Microsoft.FSharp.Primitives.Basics.List.ofArray array @@ -533,15 +533,15 @@ namespace Microsoft.FSharp.Collections let toSeq list = Seq.ofList list [] - let findIndex predicate list = - let rec loop n = function[] -> indexNotFound() | h::t -> if predicate h then n else loop (n+1) t + let findIndex predicate list = + let rec loop n = function[] -> indexNotFound() | h :: t -> if predicate h then n else loop (n+1) t loop 0 list [] - let tryFindIndex predicate list = - let rec loop n = function[] -> None | h::t -> if predicate h then Some n else loop (n+1) t + let tryFindIndex predicate list = + let rec loop n = function[] -> None | h :: t -> if predicate h then Some n else loop (n+1) t loop 0 list - + [] let findIndexBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.findIndexBack predicate @@ -550,7 +550,7 @@ namespace Microsoft.FSharp.Collections [] let inline sum (list:list<'T>) = - match list with + match list with | [] -> LanguagePrimitives.GenericZero< 'T > | t -> let mutable acc = LanguagePrimitives.GenericZero< 'T > @@ -560,7 +560,7 @@ namespace Microsoft.FSharp.Collections [] let inline sumBy (projection: 'T -> 'U) (list:list<'T>) = - match list with + match list with | [] -> LanguagePrimitives.GenericZero< 'U > | t -> let mutable acc = LanguagePrimitives.GenericZero< 'U > @@ -570,9 +570,9 @@ namespace Microsoft.FSharp.Collections [] let inline max (list:list<_>) = - match list with + match list with | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h::t -> + | h :: t -> let mutable acc = h for x in t do if x > acc then @@ -581,9 +581,9 @@ namespace Microsoft.FSharp.Collections [] let inline maxBy projection (list:list<_>) = - match list with + match list with | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h::t -> + | h :: t -> let mutable acc = h let mutable accv = projection h for x in t do @@ -592,12 +592,12 @@ namespace Microsoft.FSharp.Collections acc <- x accv <- currv acc - + [] let inline min (list:list<_>) = - match list with + match list with | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h::t -> + | h :: t -> let mutable acc = h for x in t do if x < acc then @@ -606,9 +606,9 @@ namespace Microsoft.FSharp.Collections [] let inline minBy projection (list:list<_>) = - match list with + match list with | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h::t -> + | h :: t -> let mutable acc = h let mutable accv = projection h for x in t do @@ -620,7 +620,7 @@ namespace Microsoft.FSharp.Collections [] let inline average (list:list<'T>) = - match list with + match list with | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString | xs -> let mutable sum = LanguagePrimitives.GenericZero< 'T > @@ -631,8 +631,8 @@ namespace Microsoft.FSharp.Collections LanguagePrimitives.DivideByInt sum count [] - let inline averageBy (projection : 'T -> 'U) (list:list<'T>) = - match list with + let inline averageBy (projection: 'T -> 'U) (list:list<'T>) = + match list with | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString | xs -> let mutable sum = LanguagePrimitives.GenericZero< 'U > @@ -665,20 +665,20 @@ namespace Microsoft.FSharp.Collections let permute indexMap list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.permute indexMap |> ofArray [] - let exactlyOne (list : list<_>) = + let exactlyOne (list: list<_>) = match list with | [x] -> x - | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString | _ -> invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) [] - let tryExactlyOne (list : list<_>) = + let tryExactlyOne (list: list<_>) = match list with | [x] -> Some x | _ -> None [] - let transpose (lists : seq<'T list>) = + let transpose (lists: seq<'T list>) = checkNonNull "lists" lists Microsoft.FSharp.Primitives.Basics.List.transpose (ofSeq lists) @@ -686,4 +686,4 @@ namespace Microsoft.FSharp.Collections 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 diff --git a/src/fsharp/FSharp.Core/local.fs b/src/fsharp/FSharp.Core/local.fs index 42297795184..9fb452907f4 100644 --- a/src/fsharp/FSharp.Core/local.fs +++ b/src/fsharp/FSharp.Core/local.fs @@ -8,97 +8,97 @@ module internal DetailedExceptions = open Microsoft.FSharp.Core /// takes an argument, a formatting string, a param array to splice into the formatting string - let inline invalidArgFmt (arg:string) (format:string) paramArray = - let msg = String.Format (format,paramArray) - raise (new ArgumentException (msg,arg)) + let inline invalidArgFmt (arg:string) (format:string) paramArray = + let msg = String.Format (format, paramArray) + raise (new ArgumentException (msg, arg)) /// takes a formatting string and a param array to splice into the formatting string let inline invalidOpFmt (format:string) paramArray = - let msg = String.Format (format,paramArray) + let msg = String.Format (format, paramArray) raise (new InvalidOperationException(msg)) /// throws an invalid argument exception and returns the difference between the lists' lengths let invalidArgDifferentListLength (arg1:string) (arg2:string) (diff:int) = invalidArgFmt arg1 - "{0}\n{1} is {2} {3} shorter than {4}" + "{0}\n{1} is {2} {3} shorter than {4}" [|SR.GetString SR.listsHadDifferentLengths; arg1; diff; (if diff=1 then "element" else "elements"); arg2|] /// throws an invalid argument exception and returns the length of the 3 arrays - let invalidArg3ListsDifferent (arg1:string) (arg2:string) (arg3:string) (len1:int) (len2:int) (len3:int) = + let invalidArg3ListsDifferent (arg1:string) (arg2:string) (arg3:string) (len1:int) (len2:int) (len3:int) = invalidArgFmt (String.Concat [|arg1; ", "; arg2; ", "; arg3|]) - "{0}\n {1}.Length = {2}, {3}.Length = {4}, {5}.Length = {6}" + "{0}\n {1}.Length = {2}, {3}.Length = {4}, {5}.Length = {6}" [|SR.GetString SR.listsHadDifferentLengths; arg1; len1; arg2; len2; arg3; len3|] - /// throws an invalid operation exception and returns how many elements the + /// throws an invalid operation exception and returns how many elements the /// list is shorter than the index - let invalidOpListNotEnoughElements (index:int) = - invalidOpFmt - "{0}\nThe list was {1} {2} shorter than the index" + let invalidOpListNotEnoughElements (index:int) = + invalidOpFmt + "{0}\nThe list was {1} {2} shorter than the index" [|SR.GetString SR.notEnoughElements; index; (if index=1 then "element" else "elements")|] - + /// eg. tried to {skip} {2} {elements} past the end of the seq. Seq.Length = {10} let invalidOpExceededSeqLength (fnName:string) (diff:int) (len:int) = - invalidOpFmt "{0}\ntried to {1} {2} {3} past the end of the seq\nSeq.Length = {4}" - [|SR.GetString SR.notEnoughElements; fnName; diff; (if diff=1 then "element" else "elements");len|] + invalidOpFmt "{0}\ntried to {1} {2} {3} past the end of the seq\nSeq.Length = {4}" + [|SR.GetString SR.notEnoughElements; fnName; diff; (if diff=1 then "element" else "elements");len|] /// throws an invalid argument exception and returns the arg's value let inline invalidArgInputMustBeNonNegative (arg:string) (count:int) = invalidArgFmt arg "{0}\n{1} = {2}" [|LanguagePrimitives.ErrorStrings.InputMustBeNonNegativeString ; arg; count|] - + /// throws an invalid argument exception and returns the arg's value let inline invalidArgInputMustBePositive (arg:string) (count:int) = invalidArgFmt arg "{0}\n{1} = {2}" [|SR.GetString SR.inputMustBePositive; arg; count|] /// throws an invalid argument exception and returns the out of range index, /// a text description of the range, and the bound of the range - /// e.g. sourceIndex = -4, source axis-0 lower bound = 0" + /// e.g. sourceIndex = -4, source axis-0 lower bound = 0" let invalidArgOutOfRange (arg:string) (index:int) (text:string) (bound:int) = invalidArgFmt arg - "{0}\n{1} = {2}, {3} = {4}" + "{0}\n{1} = {2}, {3} = {4}" [|SR.GetString SR.outOfRange; arg; index; text; bound|] /// throws an invalid argument exception and returns the difference between the lists' lengths let invalidArgDifferentArrayLength (arg1:string) (len1:int) (arg2:string) (len2:int) = invalidArgFmt arg1 - "{0}\n{1}.Length = {2}, {3}.Length = {4}" + "{0}\n{1}.Length = {2}, {3}.Length = {4}" [|SR.GetString SR.arraysHadDifferentLengths; arg1; len1; arg2; len2 |] /// throws an invalid argument exception and returns the lengths of the 3 arrays - let invalidArg3ArraysDifferent (arg1:string) (arg2:string) (arg3:string) (len1:int) (len2:int) (len3:int) = + let invalidArg3ArraysDifferent (arg1:string) (arg2:string) (arg3:string) (len1:int) (len2:int) (len3:int) = invalidArgFmt (String.Concat [|arg1; ", "; arg2; ", "; arg3|]) - "{0}\n {1}.Length = {2}, {3}.Length = {4}, {5}.Length = {6}" + "{0}\n {1}.Length = {2}, {3}.Length = {4}, {5}.Length = {6}" [|SR.GetString SR.arraysHadDifferentLengths; arg1; len1; arg2; len2; arg3; len3|] -namespace Microsoft.FSharp.Primitives.Basics +namespace Microsoft.FSharp.Primitives.Basics open Microsoft.FSharp.Core open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Collections open Microsoft.FSharp.Core.Operators -open System.Diagnostics.CodeAnalysis +open System.Diagnostics.CodeAnalysis open System.Collections.Generic -module internal List = +module internal List = let arrayZeroCreate (n:int) = (# "newarr !0" type ('T) n : 'T array #) - [] + [] let nonempty x = match x with [] -> false | _ -> true - let rec iter f x = match x with [] -> () | h::t -> f h; iter f t + let rec iter f x = match x with [] -> () | h :: t -> f h; iter f t // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let inline setFreshConsTail cons t = cons.(::).1 <- t + let inline setFreshConsTail cons t = cons.( :: ).1 <- t let inline freshConsNoTail h = h :: (# "ldnull" : 'T list #) - let rec distinctToFreshConsTail cons (hashSet:HashSet<_>) list = + let rec distinctToFreshConsTail cons (hashSet:HashSet<_>) list = match list with | [] -> setFreshConsTail cons [] - | x::rest -> + | x :: rest -> if hashSet.Add x then let cons2 = freshConsNoTail x setFreshConsTail cons cons2 @@ -110,17 +110,17 @@ module internal List = match list with | [] -> [] | [h] -> [h] - | x::rest -> + | x :: rest -> let hashSet = HashSet<'T>(comparer) hashSet.Add x |> ignore let cons = freshConsNoTail x distinctToFreshConsTail cons hashSet rest cons - let rec distinctByToFreshConsTail cons (hashSet:HashSet<_>) keyf list = + let rec distinctByToFreshConsTail cons (hashSet:HashSet<_>) keyf list = match list with | [] -> setFreshConsTail cons [] - | x::rest -> + | x :: rest -> if hashSet.Add(keyf x) then let cons2 = freshConsNoTail x setFreshConsTail cons cons2 @@ -128,18 +128,18 @@ module internal List = else distinctByToFreshConsTail cons hashSet keyf rest - let distinctByWithComparer (comparer: IEqualityComparer<'Key>) (keyf:'T -> 'Key) (list:'T list) = + let distinctByWithComparer (comparer: IEqualityComparer<'Key>) (keyf:'T -> 'Key) (list:'T list) = match list with | [] -> [] | [h] -> [h] - | x::rest -> + | x :: rest -> let hashSet = HashSet<'Key>(comparer) hashSet.Add(keyf x) |> ignore let cons = freshConsNoTail x distinctByToFreshConsTail cons hashSet keyf rest cons - - let countBy (dict:Dictionary<_, int>) (keyf:'T -> 'Key) = + + let countBy (dict:Dictionary<_, int>) (keyf:'T -> 'Key) = // No need to dispose enumerator Dispose does nothing. let mutable ie = dict.GetEnumerator() if not (ie.MoveNext()) then [] @@ -154,47 +154,47 @@ module internal List = cons <- cons2 setFreshConsTail cons [] res - - let rec pairwiseToFreshConsTail cons list lastvalue = + + let rec pairwiseToFreshConsTail cons list lastvalue = match list with | [] -> setFreshConsTail cons [] | [h] -> setFreshConsTail cons [(lastvalue, h)] - | h::t -> + | h :: t -> let cons2 = freshConsNoTail (lastvalue, h) setFreshConsTail cons cons2 pairwiseToFreshConsTail cons2 t h - let pairwise list = + let pairwise list = match list with | [] -> [] | [_] -> [] - | x1::x2::t -> + | x1 :: x2 :: t -> let cons = freshConsNoTail (x1, x2) pairwiseToFreshConsTail cons t x2 cons let rec chooseToFreshConsTail cons f xs = - match xs with + match xs with | [] -> setFreshConsTail cons [] - | h::t -> - match f h with - | None -> chooseToFreshConsTail cons f t - | Some x -> + | h :: t -> + match f h with + | None -> chooseToFreshConsTail cons f t + | Some x -> let cons2 = freshConsNoTail x setFreshConsTail cons cons2 chooseToFreshConsTail cons2 f t let rec choose f xs = - match xs with + match xs with | [] -> [] - | h::t -> + | h :: t -> match f h with | None -> choose f t - | Some x -> + | Some x -> let cons = freshConsNoTail x chooseToFreshConsTail cons f t cons - + let groupBy (comparer:IEqualityComparer<'SafeKey>) (keyf:'T->'SafeKey) (getKey:'SafeKey->'Key) (list: 'T list) = match list with | [] -> [] @@ -205,19 +205,19 @@ module internal List = // Build the groupings let rec loop list = match list with - | v :: t -> + | v :: t -> let safeKey = keyf v match dict.TryGetValue(safeKey) with - | true, prev -> + | true, prev -> let cons2 = freshConsNoTail v setFreshConsTail prev.[1] cons2 prev.[1] <- cons2 | _ -> let res = freshConsNoTail v dict.[safeKey] <- [|res; res |] // First index stores the result list; second index is the most recent cons. - + loop t | _ -> () - loop list + loop list let mutable ie = dict.GetEnumerator() if not (ie.MoveNext()) then [] @@ -235,124 +235,124 @@ module internal List = setFreshConsTail cons [] res - let rec mapToFreshConsTail cons f x = + let rec mapToFreshConsTail cons f x = match x with - | [] -> + | [] -> setFreshConsTail cons [] - | h::t -> + | h :: t -> let cons2 = freshConsNoTail (f h) setFreshConsTail cons cons2 mapToFreshConsTail cons2 f t - let map mapping x = + let map mapping x = match x with | [] -> [] | [h] -> [mapping h] - | h::t -> + | h :: t -> let cons = freshConsNoTail (mapping h) mapToFreshConsTail cons mapping t cons - let rec mapiToFreshConsTail cons (f:OptimizedClosures.FSharpFunc<_,_,_>) x i = + let rec mapiToFreshConsTail cons (f:OptimizedClosures.FSharpFunc<_, _, _>) x i = match x with - | [] -> + | [] -> setFreshConsTail cons [] - | h::t -> - let cons2 = freshConsNoTail (f.Invoke(i,h)) + | h :: t -> + let cons2 = freshConsNoTail (f.Invoke(i, h)) setFreshConsTail cons cons2 mapiToFreshConsTail cons2 f t (i+1) - let mapi f x = + let mapi f x = match x with | [] -> [] | [h] -> [f 0 h] - | h::t -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) - let cons = freshConsNoTail (f.Invoke(0,h)) + | h :: t -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + let cons = freshConsNoTail (f.Invoke(0, h)) mapiToFreshConsTail cons f t 1 cons - let rec map2ToFreshConsTail cons (f:OptimizedClosures.FSharpFunc<_,_,_>) xs1 xs2 = - match xs1,xs2 with - | [],[] -> + let rec map2ToFreshConsTail cons (f:OptimizedClosures.FSharpFunc<_, _, _>) xs1 xs2 = + match xs1, xs2 with + | [], [] -> setFreshConsTail cons [] - | h1::t1, h2::t2 -> - let cons2 = freshConsNoTail (f.Invoke(h1,h2)) + | h1 :: t1, h2 :: t2 -> + let cons2 = freshConsNoTail (f.Invoke(h1, h2)) setFreshConsTail cons cons2 map2ToFreshConsTail cons2 f t1 t2 - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - - let map2 mapping xs1 xs2 = - match xs1,xs2 with - | [],[] -> [] - | h1::t1, h2::t2 -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(mapping) - let cons = freshConsNoTail (f.Invoke(h1,h2)) + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + + let map2 mapping xs1 xs2 = + match xs1, xs2 with + | [], [] -> [] + | h1 :: t1, h2 :: t2 -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) + let cons = freshConsNoTail (f.Invoke(h1, h2)) map2ToFreshConsTail cons f t1 t2 cons - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - let rec map3ToFreshConsTail cons (f:OptimizedClosures.FSharpFunc<_,_,_,_>) xs1 xs2 xs3 = - match xs1,xs2,xs3 with - | [],[],[] -> + let rec map3ToFreshConsTail cons (f:OptimizedClosures.FSharpFunc<_, _, _, _>) xs1 xs2 xs3 = + match xs1, xs2, xs3 with + | [], [], [] -> setFreshConsTail cons [] - | h1::t1, h2::t2, h3::t3 -> - let cons2 = freshConsNoTail (f.Invoke(h1,h2,h3)) + | h1 :: t1, h2 :: t2, h3 :: t3 -> + let cons2 = freshConsNoTail (f.Invoke(h1, h2, h3)) setFreshConsTail cons cons2 map3ToFreshConsTail cons2 f t1 t2 t3 - | xs1,xs2,xs3 -> - invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length - - let map3 mapping xs1 xs2 xs3 = - match xs1,xs2,xs3 with - | [],[],[] -> [] - | h1::t1, h2::t2, h3::t3 -> - let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(mapping) - let cons = freshConsNoTail (f.Invoke(h1,h2,h3)) + | xs1, xs2, xs3 -> + invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length + + let map3 mapping xs1 xs2 xs3 = + match xs1, xs2, xs3 with + | [], [], [] -> [] + | h1 :: t1, h2 :: t2, h3 :: t3 -> + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(mapping) + let cons = freshConsNoTail (f.Invoke(h1, h2, h3)) map3ToFreshConsTail cons f t1 t2 t3 cons - | xs1,xs2,xs3 -> - invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length + | xs1, xs2, xs3 -> + invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length - let rec mapi2ToFreshConsTail n cons (f:OptimizedClosures.FSharpFunc<_,_,_,_>) xs1 xs2 = - match xs1,xs2 with - | [],[] -> + let rec mapi2ToFreshConsTail n cons (f:OptimizedClosures.FSharpFunc<_, _, _, _>) xs1 xs2 = + match xs1, xs2 with + | [], [] -> setFreshConsTail cons [] - | h1::t1, h2::t2 -> - let cons2 = freshConsNoTail (f.Invoke(n,h1,h2)) + | h1 :: t1, h2 :: t2 -> + let cons2 = freshConsNoTail (f.Invoke(n, h1, h2)) setFreshConsTail cons cons2 mapi2ToFreshConsTail (n + 1) cons2 f t1 t2 - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - - let mapi2 f xs1 xs2 = - match xs1,xs2 with - | [],[] -> [] - | h1::t1, h2::t2 -> - let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f) - let cons = freshConsNoTail (f.Invoke(0, h1,h2)) + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + + let mapi2 f xs1 xs2 = + match xs1, xs2 with + | [], [] -> [] + | h1 :: t1, h2 :: t2 -> + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) + let cons = freshConsNoTail (f.Invoke(0, h1, h2)) mapi2ToFreshConsTail 1 cons f t1 t2 cons - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - - let rec scanToFreshConsTail cons xs s (f: OptimizedClosures.FSharpFunc<_,_,_>) = + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + + let rec scanToFreshConsTail cons xs s (f: OptimizedClosures.FSharpFunc<_, _, _>) = match xs with | [] -> setFreshConsTail cons [] - | h::t -> - let newState = f.Invoke(s,h) + | h :: t -> + let newState = f.Invoke(s, h) let cons2 = freshConsNoTail newState setFreshConsTail cons cons2 scanToFreshConsTail cons2 t newState f - let scan f (s:'State) (list:'T list) = - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) - match list with + let scan f (s:'State) (list:'T list) = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + match list with | [] -> [s] - | _ -> + | _ -> let cons = freshConsNoTail s scanToFreshConsTail cons list s f cons @@ -361,17 +361,17 @@ module internal List = match xs with | [] -> setFreshConsTail cons [] - | h::t -> - let cons2 = freshConsNoTail (i,h) + | h :: t -> + let cons2 = freshConsNoTail (i, h) setFreshConsTail cons cons2 indexedToFreshConsTail cons2 t (i+1) let indexed xs = match xs with | [] -> [] - | [h] -> [(0,h)] - | h::t -> - let cons = freshConsNoTail (0,h) + | [h] -> [(0, h)] + | h :: t -> + let cons = freshConsNoTail (0, h) indexedToFreshConsTail cons t 1 cons @@ -380,8 +380,8 @@ module internal List = | [] -> setFreshConsTail cons [] acc - | h::t -> - let x',s' = f.Invoke(acc,h) + | h :: t -> + let x', s' = f.Invoke(acc, h) let cons2 = freshConsNoTail x' setFreshConsTail cons cons2 mapFoldToFreshConsTail cons2 f s' t @@ -390,77 +390,77 @@ module internal List = match xs with | [] -> [], acc | [h] -> - let x',s' = f acc h - [x'],s' - | h::t -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) - let x',s' = f.Invoke(acc,h) + let x', s' = f acc h + [x'], s' + | h :: t -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + let x', s' = f.Invoke(acc, h) let cons = freshConsNoTail x' let s' = mapFoldToFreshConsTail cons f s' t cons, s' - let rec forall predicate xs1 = - match xs1 with + let rec forall predicate xs1 = + match xs1 with | [] -> true - | h1::t1 -> predicate h1 && forall predicate t1 + | h1 :: t1 -> predicate h1 && forall predicate t1 - let rec exists predicate xs1 = - match xs1 with + let rec exists predicate xs1 = + match xs1 with | [] -> false - | h1::t1 -> predicate h1 || exists predicate t1 + | h1 :: t1 -> predicate h1 || exists predicate t1 - let rec revAcc xs acc = - match xs with + let rec revAcc xs acc = + match xs with | [] -> acc - | h::t -> revAcc t (h::acc) + | h :: t -> revAcc t (h :: acc) - let rev xs = - match xs with + let rev xs = + match xs with | [] -> xs | [_] -> xs - | h1::h2::t -> revAcc t [h2;h1] + | h1 :: h2 :: t -> revAcc t [h2;h1] // return the last cons it the chain - let rec appendToFreshConsTail cons xs = - match xs with - | [] -> + let rec appendToFreshConsTail cons xs = + match xs with + | [] -> setFreshConsTail cons xs // note, xs = [] cons - | h::t -> + | h :: t -> let cons2 = freshConsNoTail h setFreshConsTail cons cons2 appendToFreshConsTail cons2 t // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec collectToFreshConsTail (f:'T -> 'U list) (list:'T list) cons = - match list with - | [] -> + let rec collectToFreshConsTail (f:'T -> 'U list) (list:'T list) cons = + match list with + | [] -> setFreshConsTail cons [] - | h::t -> + | h :: t -> collectToFreshConsTail f t (appendToFreshConsTail cons (f h)) - let rec collect (f:'T -> 'U list) (list:'T list) = + let rec collect (f:'T -> 'U list) (list:'T list) = match list with | [] -> [] | [h] -> f h | _ -> let cons = freshConsNoTail (Unchecked.defaultof<'U>) collectToFreshConsTail f list cons - cons.Tail + cons.Tail let rec allPairsToFreshConsTailSingle x ys cons = match ys with | [] -> cons - | h2::t2 -> - let cons2 = freshConsNoTail (x,h2) + | h2 :: t2 -> + let cons2 = freshConsNoTail (x, h2) setFreshConsTail cons cons2 allPairsToFreshConsTailSingle x t2 cons2 let rec allPairsToFreshConsTail xs ys cons = match xs with | [] -> setFreshConsTail cons [] - | h::t -> + | h :: t -> let p = allPairsToFreshConsTailSingle h ys cons allPairsToFreshConsTail t ys p @@ -475,53 +475,53 @@ module internal List = // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec filterToFreshConsTail cons f l = - match l with - | [] -> + let rec filterToFreshConsTail cons f l = + match l with + | [] -> setFreshConsTail cons l // note, l = nil - | h::t -> - if f h then - let cons2 = freshConsNoTail h + | h :: t -> + if f h then + let cons2 = freshConsNoTail h setFreshConsTail cons cons2 filterToFreshConsTail cons2 f t - else + else filterToFreshConsTail cons f t - - let rec filter predicate l = - match l with + + let rec filter predicate l = + match l with | [] -> l | h :: ([] as nil) -> if predicate h then l else nil - | h::t -> - if predicate h then - let cons = freshConsNoTail h + | h :: t -> + if predicate h then + let cons = freshConsNoTail h filterToFreshConsTail cons predicate t cons - else + else filter predicate t - let iteri action x = - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) - let rec loop n x = - match x with - | [] -> () - | h::t -> f.Invoke(n,h); loop (n+1) t + let iteri action x = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) + let rec loop n x = + match x with + | [] -> () + | h :: t -> f.Invoke(n, h); loop (n+1) t loop 0 x // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec concatToFreshConsTail cons h1 l = - match l with + let rec concatToFreshConsTail cons h1 l = + match l with | [] -> setFreshConsTail cons h1 - | h2::t -> concatToFreshConsTail (appendToFreshConsTail cons h1) h2 t - + | h2 :: t -> concatToFreshConsTail (appendToFreshConsTail cons h1) h2 t + // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec concatToEmpty l = - match l with + let rec concatToEmpty l = + match l with | [] -> [] - | []::t -> concatToEmpty t - | (h::t1)::tt2 -> + | [] :: t -> concatToEmpty t + | (h :: t1) :: tt2 -> let res = freshConsNoTail h concatToFreshConsTail res t1 tt2 res @@ -532,13 +532,13 @@ module internal List = let rec loop i l = match l with | [] -> () - | h::t -> + | h :: t -> res.[i] <- h loop (i+1) t loop 0 l res - let ofArray (arr:'T[]) = + let ofArray (arr:'T[]) = let mutable res = ([]: 'T list) for i = arr.Length-1 downto 0 do res <- arr.[i] :: res @@ -561,26 +561,25 @@ module internal List = setFreshConsTail cons [] res - let concat (l : seq<_>) = + let concat (l : seq<_>) = match ofSeq l with | [] -> [] | [h] -> h | [h1;h2] -> h1 @ h2 | l -> concatToEmpty l - let rec initToFreshConsTail cons i n f = - if i < n then + let rec initToFreshConsTail cons i n f = + if i < n then let cons2 = freshConsNoTail (f i) setFreshConsTail cons cons2 - initToFreshConsTail cons2 (i+1) n f - else + initToFreshConsTail cons2 (i+1) n f + else setFreshConsTail cons [] - - - let init count f = + + let init count f = if count < 0 then invalidArgInputMustBeNonNegative "count" count - if count = 0 then [] - else + if count = 0 then [] + else let res = freshConsNoTail (f 0) initToFreshConsTail res 1 count f res @@ -589,17 +588,17 @@ module internal List = if n = 0 then setFreshConsTail cons [] else match l with | [] -> invalidOpListNotEnoughElements n - | x::xs -> + | x :: xs -> let cons2 = freshConsNoTail x setFreshConsTail cons cons2 takeFreshConsTail cons2 (n - 1) xs - + let take n l = if n < 0 then invalidArgInputMustBeNonNegative "count" n - if n = 0 then [] else + if n = 0 then [] else match l with | [] -> invalidOpListNotEnoughElements n - | x::xs -> + | x :: xs -> let cons = freshConsNoTail x takeFreshConsTail cons (n - 1) xs cons @@ -615,73 +614,73 @@ module internal List = let cons2 = freshConsNoTail x setFreshConsTail cons cons2 splitAtFreshConsTail cons2 (index - 1) xs - + let splitAt index l = if index < 0 then invalidArgInputMustBeNonNegative "index" index if index = 0 then [], l else match l with | [] -> invalidOp (SR.GetString SR.inputListWasEmpty) - | [_] -> - if index = 1 then l, [] else - invalidOpListNotEnoughElements (index-1) - | x::xs -> + | [_] -> + if index = 1 then l, [] else + invalidOpListNotEnoughElements (index-1) + | x :: xs -> if index = 1 then [x], xs else let cons = freshConsNoTail x let tail = splitAtFreshConsTail cons (index - 1) xs - cons, tail - + cons, tail + // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec partitionToFreshConsTails consL consR p l = - match l with - | [] -> + let rec partitionToFreshConsTails consL consR p l = + match l with + | [] -> setFreshConsTail consL l // note, l = nil setFreshConsTail consR l // note, l = nil - - | h::t -> + + | h :: t -> let cons' = freshConsNoTail h - if p h then + if p h then setFreshConsTail consL cons' partitionToFreshConsTails cons' consR p t - else + else setFreshConsTail consR cons' partitionToFreshConsTails consL cons' p t - - let rec partitionToFreshConsTailLeft consL p l = - match l with - | [] -> + + let rec partitionToFreshConsTailLeft consL p l = + match l with + | [] -> setFreshConsTail consL l // note, l = nil l // note, l = nil - | h::t -> - let cons' = freshConsNoTail h - if p h then + | h :: t -> + let cons' = freshConsNoTail h + if p h then setFreshConsTail consL cons' partitionToFreshConsTailLeft cons' p t - else + else partitionToFreshConsTails consL cons' p t cons' - let rec partitionToFreshConsTailRight consR p l = - match l with - | [] -> + let rec partitionToFreshConsTailRight consR p l = + match l with + | [] -> setFreshConsTail consR l // note, l = nil l // note, l = nil - | h::t -> - let cons' = freshConsNoTail h - if p h then + | h :: t -> + let cons' = freshConsNoTail h + if p h then partitionToFreshConsTails cons' consR p t cons' - else + else setFreshConsTail consR cons' partitionToFreshConsTailRight cons' p t - let partition predicate l = - match l with - | [] -> l,l - | h :: ([] as nil) -> if predicate h then l,nil else nil,l - | h::t -> - let cons = freshConsNoTail h - if predicate h + let partition predicate l = + match l with + | [] -> l, l + | h :: ([] as nil) -> if predicate h then l, nil else nil, l + | h :: t -> + let cons = freshConsNoTail h + if predicate h then cons, (partitionToFreshConsTailLeft cons predicate t) else (partitionToFreshConsTailRight cons predicate t), cons @@ -691,13 +690,13 @@ module internal List = setFreshConsTail headsCons [] setFreshConsTail tailsCons [] headCount - | head::tail -> + | head :: tail -> match head with | [] -> setFreshConsTail headsCons [] setFreshConsTail tailsCons [] headCount - | h::t -> + | h :: t -> let headsCons2 = freshConsNoTail h setFreshConsTail headsCons headsCons2 let tailsCons2 = freshConsNoTail t @@ -707,8 +706,8 @@ module internal List = /// Split off the heads of the lists let transposeGetHeads list = match list with - | [] -> [],[],0 - | head::tail -> + | [] -> [], [], 0 + | head :: tail -> match head with | [] -> let mutable j = 0 @@ -716,8 +715,8 @@ module internal List = j <- j + 1 if not t.IsEmpty then invalidArgDifferentListLength "list.[0]" (System.String.Format("list.[{0}]", j)) t.Length - [],[],0 - | h::t -> + [], [], 0 + | h :: t -> let headsCons = freshConsNoTail h let tailsCons = freshConsNoTail t let headCount = transposeGetHeadsFreshConsTail headsCons tailsCons tail 1 @@ -729,9 +728,9 @@ module internal List = | [] -> setFreshConsTail cons [] | _ -> match transposeGetHeads list with - | [],_,_ -> + | [], _, _ -> setFreshConsTail cons [] - | heads,tails,headCount -> + | heads, tails, headCount -> if headCount < expectedCount then invalidArgDifferentListLength (System.String.Format("list.[{0}]", headCount)) "list.[0]" <| tails.[0].Length + 1 let cons2 = freshConsNoTail heads @@ -754,19 +753,19 @@ module internal List = if count = 0 then setFreshConsTail cons [] else match list with | [] -> setFreshConsTail cons [] - | h::t -> + | h :: t -> let cons2 = freshConsNoTail h setFreshConsTail cons cons2 truncateToFreshConsTail cons2 (count-1) t let truncate count list = - if count <= 0 then + if count <= 0 then [] else match list with | [] | [_] -> list - | h::t -> + | h :: t -> let cons = freshConsNoTail h truncateToFreshConsTail cons (count-1) t cons @@ -774,7 +773,7 @@ module internal List = let rec unfoldToFreshConsTail cons f s = match f s with | None -> setFreshConsTail cons [] - | Some (x,s') -> + | Some (x, s') -> let cons2 = freshConsNoTail x setFreshConsTail cons cons2 unfoldToFreshConsTail cons2 f s' @@ -782,19 +781,19 @@ module internal List = let unfold (f:'State -> ('T * 'State) option) (s:'State) = match f s with | None -> [] - | Some (x,s') -> + | Some (x, s') -> let cons = freshConsNoTail x unfoldToFreshConsTail cons f s' cons // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec unzipToFreshConsTail cons1a cons1b x = - match x with - | [] -> + let rec unzipToFreshConsTail cons1a cons1b x = + match x with + | [] -> setFreshConsTail cons1a [] setFreshConsTail cons1b [] - | (h1,h2)::t -> + | (h1, h2) :: t -> let cons2a = freshConsNoTail h1 let cons2b = freshConsNoTail h2 setFreshConsTail cons1a cons2a @@ -803,25 +802,25 @@ module internal List = // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let unzip x = - match x with - | [] -> - [],[] - | (h1,h2)::t -> + let unzip x = + match x with + | [] -> + [], [] + | (h1, h2) :: t -> let res1a = freshConsNoTail h1 let res1b = freshConsNoTail h2 unzipToFreshConsTail res1a res1b t - res1a,res1b + res1a, res1b // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec unzip3ToFreshConsTail cons1a cons1b cons1c x = - match x with - | [] -> + let rec unzip3ToFreshConsTail cons1a cons1b cons1c x = + match x with + | [] -> setFreshConsTail cons1a [] setFreshConsTail cons1b [] setFreshConsTail cons1c [] - | (h1,h2,h3)::t -> + | (h1, h2, h3) :: t -> let cons2a = freshConsNoTail h1 let cons2b = freshConsNoTail h2 let cons2c = freshConsNoTail h3 @@ -832,16 +831,16 @@ module internal List = // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let unzip3 x = - match x with - | [] -> - [],[],[] - | (h1,h2,h3)::t -> + let unzip3 x = + match x with + | [] -> + [], [], [] + | (h1, h2, h3) :: t -> let res1a = freshConsNoTail h1 let res1b = freshConsNoTail h2 - let res1c = freshConsNoTail h3 + let res1c = freshConsNoTail h3 unzip3ToFreshConsTail res1a res1b res1c t - res1a,res1b,res1c + res1a, res1b, res1c let rec windowedToFreshConsTail cons windowSize i list = if i = 0 then @@ -866,7 +865,7 @@ module internal List = | [] -> setFreshConsTail chunkCons [] setFreshConsTail resCons [] - | h::t -> + | h :: t -> let cons = freshConsNoTail h if i = chunkSize then setFreshConsTail chunkCons [] @@ -881,7 +880,7 @@ module internal List = if chunkSize <= 0 then invalidArgInputMustBePositive "chunkSize" chunkSize match list with | [] -> [] - | head::tail -> + | head :: tail -> let chunkCons = freshConsNoTail head let res = freshConsNoTail chunkCons chunkBySizeToFreshConsTail chunkCons res chunkSize 1 tail @@ -892,7 +891,7 @@ module internal List = | [] -> setFreshConsTail chunkCons [] setFreshConsTail resCons [] - | h::t -> + | h :: t -> let cons = freshConsNoTail h if (i < lenModCount && j = lenDivCount + 1) || (i >= lenModCount && j = lenDivCount) then setFreshConsTail chunkCons [] @@ -916,59 +915,59 @@ module internal List = // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec zipToFreshConsTail cons xs1 xs2 = - match xs1,xs2 with - | [],[] -> + let rec zipToFreshConsTail cons xs1 xs2 = + match xs1, xs2 with + | [], [] -> setFreshConsTail cons [] - | h1::t1, h2::t2 -> - let cons2 = freshConsNoTail (h1,h2) + | h1 :: t1, h2 :: t2 -> + let cons2 = freshConsNoTail (h1, h2) setFreshConsTail cons cons2 zipToFreshConsTail cons2 t1 t2 - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let zip xs1 xs2 = - match xs1,xs2 with - | [],[] -> [] - | h1::t1, h2::t2 -> - let res = freshConsNoTail (h1,h2) + let zip xs1 xs2 = + match xs1, xs2 with + | [], [] -> [] + | h1 :: t1, h2 :: t2 -> + let res = freshConsNoTail (h1, h2) zipToFreshConsTail res t1 t2 res - | [],xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1,[] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let rec zip3ToFreshConsTail cons xs1 xs2 xs3 = - match xs1,xs2,xs3 with - | [],[],[] -> + let rec zip3ToFreshConsTail cons xs1 xs2 xs3 = + match xs1, xs2, xs3 with + | [], [], [] -> setFreshConsTail cons [] - | h1::t1, h2::t2, h3::t3 -> - let cons2 = freshConsNoTail (h1,h2,h3) + | h1 :: t1, h2 :: t2, h3 :: t3 -> + let cons2 = freshConsNoTail (h1, h2, h3) setFreshConsTail cons cons2 zip3ToFreshConsTail cons2 t1 t2 t3 - | xs1,xs2,xs3 -> - invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length + | xs1, xs2, xs3 -> + invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length // optimized mutation-based implementation. This code is only valid in fslib, where mutation of private // tail cons cells is permitted in carefully written library code. - let zip3 xs1 xs2 xs3 = - match xs1,xs2,xs3 with - | [],[],[] -> + let zip3 xs1 xs2 xs3 = + match xs1, xs2, xs3 with + | [], [], [] -> [] - | h1::t1, h2::t2, h3::t3 -> - let res = freshConsNoTail (h1,h2,h3) + | h1 :: t1, h2 :: t2, h3 :: t3 -> + let res = freshConsNoTail (h1, h2, h3) zip3ToFreshConsTail res t1 t2 t3 res - | xs1,xs2,xs3 -> - invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length + | xs1, xs2, xs3 -> + invalidArg3ListsDifferent "list1" "list2" "list3" xs1.Length xs2.Length xs3.Length let rec takeWhileFreshConsTail cons p l = match l with | [] -> setFreshConsTail cons [] - | x::xs -> + | x :: xs -> if p x then let cons2 = freshConsNoTail x setFreshConsTail cons cons2 @@ -980,13 +979,13 @@ module internal List = match l with | [] -> l | x :: ([] as nil) -> if p x then l else nil - | x::xs -> + | x :: xs -> if not (p x) then [] else let cons = freshConsNoTail x takeWhileFreshConsTail cons p xs cons -module internal Array = +module internal Array = open System @@ -994,13 +993,13 @@ module internal Array = LanguagePrimitives.FastGenericComparerCanBeNull<'t> // The input parameter should be checked by callers if necessary - let inline zeroCreateUnchecked (count:int) = + let inline zeroCreateUnchecked (count:int) = (# "newarr !0" type ('T) count : 'T array #) - let inline init (count:int) (f: int -> 'T) = + let inline init (count:int) (f: int -> 'T) = if count < 0 then invalidArgInputMustBeNonNegative "count" count - let arr = (zeroCreateUnchecked count : 'T array) - for i = 0 to arr.Length-1 do + let arr = (zeroCreateUnchecked count : 'T array) + for i = 0 to arr.Length-1 do arr.[i] <- f i arr @@ -1034,15 +1033,15 @@ module internal Array = else loop (i - 1) loop (array.Length - 1) - let permute indexMap (arr : _[]) = + let permute indexMap (arr : _[]) = let res = zeroCreateUnchecked arr.Length let inv = zeroCreateUnchecked arr.Length - for i = 0 to arr.Length - 1 do - let j = indexMap i + for i = 0 to arr.Length - 1 do + let j = indexMap i if j < 0 || j >= arr.Length then invalidArg "indexMap" (SR.GetString(SR.notAPermutation)) res.[j] <- arr.[i] inv.[j] <- 1uy - for i = 0 to arr.Length - 1 do + for i = 0 to arr.Length - 1 do if inv.[i] <> 1uy then invalidArg "indexMap" (SR.GetString(SR.notAPermutation)) res @@ -1050,11 +1049,11 @@ module internal Array = match array.Length with | 0 -> [| |], acc | len -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) let mutable acc = acc let res = zeroCreateUnchecked len for i = 0 to array.Length-1 do - let h',s' = f.Invoke(acc,array.[i]) + let h', s' = f.Invoke(acc, array.[i]) res.[i] <- h' acc <- s' res, acc @@ -1063,17 +1062,17 @@ module internal Array = match array.Length with | 0 -> [| |], acc | len -> - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) let mutable acc = acc let res = zeroCreateUnchecked len for i = len - 1 downto 0 do - let h',s' = f.Invoke(array.[i],acc) + let h', s' = f.Invoke(array.[i], acc) res.[i] <- h' acc <- s' res, acc let scanSubRight f (array : _[]) start fin initState = - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) let mutable state = initState let res = zeroCreateUnchecked (fin-start+2) res.[fin - start + 1] <- state @@ -1083,25 +1082,25 @@ module internal Array = res let unstableSortInPlaceBy (projection: 'T -> 'U) (array : array<'T>) = - let len = array.Length - if len < 2 then () + let len = array.Length + if len < 2 then () else let keys = zeroCreateUnchecked array.Length - for i = 0 to array.Length - 1 do + for i = 0 to array.Length - 1 do keys.[i] <- projection array.[i] - Array.Sort<_,_>(keys, array, fastComparerForArraySort()) + Array.Sort<_, _>(keys, array, fastComparerForArraySort()) - let unstableSortInPlace (array : array<'T>) = - let len = array.Length - if len < 2 then () + let unstableSortInPlace (array : array<'T>) = + let len = array.Length + if len < 2 then () else Array.Sort<_>(array, fastComparerForArraySort()) let stableSortWithKeysAndComparer (cFast:IComparer<'Key>) (c:IComparer<'Key>) (array:array<'T>) (keys:array<'Key>) = // 'places' is an array or integers storing the permutation performed by the sort - let places = zeroCreateUnchecked array.Length - for i = 0 to array.Length - 1 do - places.[i] <- i - System.Array.Sort<_,_>(keys, places, cFast) + let places = zeroCreateUnchecked array.Length + for i = 0 to array.Length - 1 do + places.[i] <- i + System.Array.Sort<_, _>(keys, places, cFast) // 'array2' is a copy of the original values let array2 = (array.Clone() :?> array<'T>) @@ -1109,17 +1108,17 @@ module internal Array = let mutable i = 0 let len = array.Length let intCompare = fastComparerForArraySort() - - while i < len do + + while i < len do let mutable j = i let ki = keys.[i] - while j < len && (j = i || c.Compare(ki, keys.[j]) = 0) do + while j < len && (j = i || c.Compare(ki, keys.[j]) = 0) do j <- j + 1 // Copy the values into the result array and re-sort the chunk if needed by the original place indexes for n = i to j - 1 do array.[n] <- array2.[places.[n]] if j - i >= 2 then - Array.Sort<_,_>(places, array, i, j-i, intCompare) + Array.Sort<_, _>(places, array, i, j-i, intCompare) i <- j let stableSortWithKeys (array:array<'T>) (keys:array<'Key>) = @@ -1128,26 +1127,26 @@ module internal Array = stableSortWithKeysAndComparer cFast c array keys let stableSortInPlaceBy (projection: 'T -> 'U) (array : array<'T>) = - let len = array.Length - if len < 2 then () + let len = array.Length + if len < 2 then () else // 'keys' is an array storing the projected keys let keys = zeroCreateUnchecked array.Length - for i = 0 to array.Length - 1 do + for i = 0 to array.Length - 1 do keys.[i] <- projection array.[i] stableSortWithKeys array keys let stableSortInPlace (array : array<'T>) = - let len = array.Length - if len < 2 then () + let len = array.Length + if len < 2 then () else let cFast = LanguagePrimitives.FastGenericComparerCanBeNull<'T> - match cFast with - | null -> + match cFast with + | null -> // An optimization for the cases where the keys and values coincide and do not have identity, e.g. are integers // In this case an unstable sort is just as good as a stable sort (and faster) - Array.Sort<_,_>(array, null) - | _ -> + Array.Sort<_, _>(array, null) + | _ -> // 'keys' is an array storing the projected keys let keys = (array.Clone() :?> array<'T>) stableSortWithKeys array keys @@ -1156,8 +1155,8 @@ module internal Array = let len = array.Length if len > 1 then let keys = (array.Clone() :?> array<'T>) - let comparer = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(comparer) - let c = { new IComparer<'T> with member __.Compare(x,y) = comparer.Invoke(x,y) } + let comparer = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(comparer) + let c = { new IComparer<'T> with member __.Compare(x, y) = comparer.Invoke(x, y) } stableSortWithKeysAndComparer c c array keys let inline subUnchecked startIndex count (array : 'T[]) = diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 9b2fbc9d832..93504de7f7c 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -2,754 +2,832 @@ namespace Microsoft.FSharp.Collections - open System - open System.Collections.Generic - open System.Diagnostics - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open System +open System.Collections.Generic +open System.Diagnostics +open System.Text +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators + +[] +[] +type MapTree<'Key, 'Value when 'Key : comparison > = + | MapEmpty + | MapOne of 'Key * 'Value + | MapNode of 'Key * 'Value * MapTree<'Key, 'Value> * MapTree<'Key, 'Value> * int + +[] +module MapTree = + + let rec sizeAux acc m = + match m with + | MapEmpty -> acc + | MapOne _ -> acc + 1 + | MapNode (_, _, l, r, _) -> sizeAux (sizeAux (acc+1) l) r + + let size x = sizeAux 0 x - [] - [] - type MapTree<'Key,'Value when 'Key : comparison > = - | MapEmpty - | MapOne of 'Key * 'Value - | MapNode of 'Key * 'Value * MapTree<'Key,'Value> * MapTree<'Key,'Value> * int - // REVIEW: performance rumour has it that the data held in MapNode and MapOne should be - // exactly one cache line. It is currently ~7 and 4 words respectively. - - [] - module MapTree = - - let rec sizeAux acc m = - match m with - | MapEmpty -> acc - | MapOne _ -> acc + 1 - | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r - - let size x = sizeAux 0 x - - - #if TRACE_SETS_AND_MAPS - let mutable traceCount = 0 - let mutable numOnes = 0 - let mutable numNodes = 0 - let mutable numAdds = 0 - let mutable numRemoves = 0 - let mutable numLookups = 0 - let mutable numUnions = 0 - let mutable totalSizeOnNodeCreation = 0.0 - let mutable totalSizeOnMapAdd = 0.0 - let mutable totalSizeOnMapLookup = 0.0 - 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 MapOne n = - report(); - numOnes <- numOnes + 1; - totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0; - MapTree.MapOne n - - let MapNode (x,l,v,r,h) = - report(); - numNodes <- numNodes + 1; - let n = MapTree.MapNode(x,l,v,r,h) - totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (size n); - n - #endif - - let empty = MapEmpty - - let height (m: MapTree<'Key, 'Value>) = - match m with - | MapEmpty -> 0 - | MapOne _ -> 1 - | MapNode(_,_,_,_,h) -> h - - let isEmpty (m: MapTree<'Key, 'Value>) = - match m with - | MapEmpty -> true - | _ -> false +#if TRACE_SETS_AND_MAPS + let mutable traceCount = 0 + let mutable numOnes = 0 + let mutable numNodes = 0 + let mutable numAdds = 0 + let mutable numRemoves = 0 + let mutable numLookups = 0 + let mutable numUnions = 0 + let mutable totalSizeOnNodeCreation = 0.0 + let mutable totalSizeOnMapAdd = 0.0 + let mutable totalSizeOnMapLookup = 0.0 + 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 MapOne n = + report() + numOnes <- numOnes + 1 + totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 + MapTree.MapOne n + + let MapNode (x, l, v, r, h) = + report() + numNodes <- numNodes + 1 + let n = MapTree.MapNode (x, l, v, r, h) + totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (size n) + n +#endif - let mk l k v r : MapTree<'Key, 'Value> = - match l,r with - | MapEmpty,MapEmpty -> MapOne(k,v) - | _ -> - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - MapNode(k,v,l,r,m+1) - - let rebalance t1 (k: 'Key) (v: 'Value) t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + 2 then (* right is heavier than left *) - match t2 with - | MapNode(t2k,t2v,t2l,t2r,_) -> - (* one of the nodes must have height > height t1 + 1 *) - if height t2l > t1h + 1 then (* balance left: combination *) - match t2l with - | MapNode(t2lk,t2lv,t2ll,t2lr,_) -> - mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) - | _ -> failwith "rebalance" - else (* rotate left *) - mk (mk t1 k v t2l) t2k t2v t2r - | _ -> failwith "rebalance" - else - if t1h > t2h + 2 then (* left is heavier than right *) - match t1 with - | MapNode(t1k,t1v,t1l,t1r,_) -> - (* one of the nodes must have height > height t2 + 1 *) - if height t1r > t2h + 1 then - (* balance right: combination *) + let empty = MapEmpty + + let height (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> 0 + | MapOne _ -> 1 + | MapNode (_, _, _, _, h) -> h + + let isEmpty (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> true + | _ -> false + + let mk l k v r : MapTree<'Key, 'Value> = + match l, r with + | MapEmpty, MapEmpty -> MapOne (k, v) + | _ -> + let hl = height l + let hr = height r + let m = if hl < hr then hr else hl + MapNode (k, v, l, r, m+1) + + let rebalance t1 (k: 'Key) (v: 'Value) t2 = + let t1h = height t1 + let t2h = height t2 + if t2h > t1h + 2 then (* right is heavier than left *) + match t2 with + | MapNode (t2k, t2v, t2l, t2r, _) -> + // one of the nodes must have height > height t1 + 1 + if height t2l > t1h + 1 then + // balance left: combination + match t2l with + | MapNode (t2lk, t2lv, t2ll, t2lr, _) -> + mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) + | _ -> failwith "rebalance" + else + // rotate left + mk (mk t1 k v t2l) t2k t2v t2r + | _ -> failwith "rebalance" + else + if t1h > t2h + 2 then (* left is heavier than right *) + match t1 with + | MapNode (t1k, t1v, t1l, t1r, _) -> + // one of the nodes must have height > height t2 + 1 + if height t1r > t2h + 1 then + // balance right: combination match t1r with - | MapNode(t1rk,t1rv,t1rl,t1rr,_) -> + | MapNode (t1rk, t1rv, t1rl, t1rr, _) -> mk (mk t1l t1k t1v t1rl) t1rk t1rv (mk t1rr k v t2) | _ -> failwith "rebalance" - else + else mk t1l t1k t1v (mk t1r k v t2) - | _ -> failwith "rebalance" - else mk t1 k v t2 - - let rec add (comparer: IComparer<'Key>) k (v: 'Value) (m: MapTree<'Key, 'Value>) = + | _ -> failwith "rebalance" + else mk t1 k v t2 + + let rec add (comparer: IComparer<'Key>) k (v: 'Value) (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> MapOne (k, v) + | MapOne (k2, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then MapNode (k, v, MapEmpty, m, 2) + elif c = 0 then MapOne (k, v) + else MapNode (k, v, m, MapEmpty, 2) + | MapNode (k2, v2, l, r, h) -> + let c = comparer.Compare(k, k2) + if c < 0 then rebalance (add comparer k v l) k2 v2 r + elif c = 0 then MapNode (k, v, l, r, h) + else rebalance l k2 v2 (add comparer k v r) + + let rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> false + | MapOne (k2, v2) -> + let c = comparer.Compare(k, k2) + if c = 0 then v <- v2; true + else false + | MapNode (k2, v2, l, r, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then tryGetValue comparer k &v l + elif c = 0 then v <- v2; true + else tryGetValue comparer k &v r + + 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 + raise (KeyNotFoundException()) + + let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let mutable v = Unchecked.defaultof<'Value> + if tryGetValue comparer k &v m then + Some v + else + None + + let partition1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v (acc1, acc2) = + if f.Invoke (k, v) then (add comparer k v acc1, acc2) else (acc1, add comparer k v acc2) + + let rec partitionAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) m acc = + match m with + | MapEmpty -> acc + | MapOne (k, v) -> partition1 comparer f k v acc + | MapNode (k, v, l, r, _) -> + let acc = partitionAux comparer f r acc + let acc = partition1 comparer f k v acc + partitionAux comparer f l 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 + + let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) m acc = + match m with + | MapEmpty -> acc + | MapOne (k, v) -> filter1 comparer f k v acc + | MapNode (k, v, l, r, _) -> + let acc = filterAux comparer f l acc + let acc = filter1 comparer f k v acc + filterAux comparer f r acc + + let filter (comparer: IComparer<'Key>) f m = + filterAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m empty + + let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> failwith "internal error: Map.spliceOutSuccessor" + | MapOne (k2, v2) -> k2, v2, MapEmpty + | MapNode (k2, v2, l, r, _) -> + match l with + | MapEmpty -> k2, v2, r + | _ -> let k3, v3, l' = spliceOutSuccessor l in k3, v3, mk l' k2 v2 r + + let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> empty + | MapOne (k2, _) -> + let c = comparer.Compare(k, k2) + if c = 0 then MapEmpty else m + | MapNode (k2, v2, l, r, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then rebalance (remove comparer k l) k2 v2 r + elif c = 0 then + match l, r with + | MapEmpty, _ -> r + | _, MapEmpty -> l + | _ -> + let sk, sv, r' = spliceOutSuccessor r + mk l sk sv r' + else rebalance l k2 v2 (remove comparer k r) + + let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> false + | MapOne (k2, _) -> (comparer.Compare(k, k2) = 0) + | MapNode (k2, _, l, r, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then mem comparer k l + else (c = 0 || mem comparer k r) + + let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + match m with + | MapEmpty -> () + | MapOne (k2, v2) -> f.Invoke (k2, v2) + | MapNode (k2, v2, l, r, _) -> iterOpt f l; f.Invoke (k2, v2); iterOpt f r + + let iter f m = + iterOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m + + let rec tryPickOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) m = + match m with + | MapEmpty -> None + | MapOne (k2, v2) -> f.Invoke (k2, v2) + | MapNode (k2, v2, l, r, _) -> + match tryPickOpt f l with + | Some _ as res -> res + | None -> + match f.Invoke (k2, v2) with + | Some _ as res -> res + | None -> + tryPickOpt f r + + let tryPick f m = + tryPickOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m + + let rec existsOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) m = + match m with + | MapEmpty -> false + | MapOne (k2, v2) -> f.Invoke (k2, v2) + | MapNode (k2, v2, l, r, _) -> existsOpt f l || f.Invoke (k2, v2) || existsOpt f r + + let exists f m = + existsOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m + + let rec forallOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) m = + match m with + | MapEmpty -> true + | MapOne (k2, v2) -> f.Invoke (k2, v2) + | MapNode (k2, v2, l, r, _) -> forallOpt f l && f.Invoke (k2, v2) && forallOpt f r + + let forall f m = + forallOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m + + let rec map f m = + match m with + | MapEmpty -> empty + | MapOne (k, v) -> MapOne (k, f v) + | MapNode (k, v, l, r, h) -> + let l2 = map f l + let v2 = f v + let r2 = map f r + MapNode (k, v2, l2, r2, h) + + let rec mapiOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) m = + match m with + | MapEmpty -> empty + | MapOne (k, v) -> MapOne (k, f.Invoke (k, v)) + | MapNode (k, v, l, r, h) -> + let l2 = mapiOpt f l + let v2 = f.Invoke (k, v) + let r2 = mapiOpt f r + MapNode (k, v2, l2, r2, h) + + let mapi f m = + mapiOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m + + let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) m x = + match m with + | MapEmpty -> x + | MapOne (k, v) -> f.Invoke (k, v, x) + | MapNode (k, v, l, r, _) -> + let x = foldBackOpt f r x + let x = f.Invoke (k, v, x) + foldBackOpt f l x + + let foldBack f m x = + foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f)) m x + + let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) x m = + match m with + | MapEmpty -> x + | MapOne (k, v) -> f.Invoke (x, k, v) + | MapNode (k, v, l, r, _) -> + let x = foldOpt f x l + let x = f.Invoke (x, k, v) + foldOpt f x r + + let fold f x m = + foldOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f)) x m + + let foldSectionOpt (comparer: IComparer<'Key>) lo hi (f: OptimizedClosures.FSharpFunc<_, _, _, _>) m x = + let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) m x = match m with - | MapEmpty -> MapOne(k,v) - | MapOne(k2,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then MapNode (k,v,MapEmpty,m,2) - elif c = 0 then MapOne(k,v) - else MapNode (k,v,m,MapEmpty,2) - | MapNode(k2,v2,l,r,h) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k v l) k2 v2 r - elif c = 0 then MapNode(k,v,l,r,h) - else rebalance l k2 v2 (add comparer k v r) - - let rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = + | MapEmpty -> x + | MapOne (k, v) -> + let cLoKey = comparer.Compare(lo, k) + let cKeyHi = comparer.Compare(k, hi) + let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (k, v, x) else x + x + | MapNode (k, v, l, r, _) -> + let cLoKey = comparer.Compare(lo, k) + let cKeyHi = comparer.Compare(k, hi) + let x = if cLoKey < 0 then foldFromTo f l x else x + let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (k, v, x) else x + let x = if cKeyHi < 0 then foldFromTo f r 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 = + let rec loop m acc = match m with - | MapEmpty -> false - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then v <- v2; true - else false - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then tryGetValue comparer k &v l - elif c = 0 then v <- v2; true - else tryGetValue comparer k &v r - - 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 - raise (KeyNotFoundException()) - - let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = - let mutable v = Unchecked.defaultof<'Value> - if tryGetValue comparer k &v m then - Some v - else - None - - let partition1 (comparer: IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v (acc1,acc2) = - if f.Invoke(k, v) then (add comparer k v acc1,acc2) else (acc1,add comparer k v acc2) - - let rec partitionAux (comparer: IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = - match s with | MapEmpty -> acc - | MapOne(k,v) -> partition1 comparer f k v acc - | MapNode(k,v,l,r,_) -> - let acc = partitionAux comparer f r acc - let acc = partition1 comparer f k v acc - partitionAux comparer f l acc + | MapOne (k, v) -> (k, v):: acc + | MapNode (k, v, l, r, _) -> loop l ((k, v):: loop r acc) + loop m [] + + let toArray m = + m |> toList |> Array.ofList + + 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 + mkFromEnumerator comparer (add comparer x y acc) e + else acc + + let ofArray comparer (arr : array<_>) = + let mutable res = empty + for (x, y) in arr do + res <- add comparer x y res + res + + let ofSeq comparer (c : seq<'Key * 'T>) = + match c with + | :? array<'Key * 'T> as xs -> ofArray comparer xs + | :? list<'Key * 'T> as xs -> ofList comparer xs + | _ -> + use ie = c.GetEnumerator() + mkFromEnumerator comparer empty ie + + let copyToArray m (arr: _[]) i = + let j = ref 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 + + /// 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 = + match stack with + | [] -> [] + | MapEmpty :: rest -> collapseLHS rest + | MapOne _ :: _ -> stack + | (MapNode (k, v, l, r, _)) :: rest -> collapseLHS (l :: MapOne (k, v) :: r :: rest) + + let mkIterator m = + { stack = collapseLHS [m]; started = false } + + let notStarted() = + raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) + + let alreadyFinished() = + raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + + let current i = + if i.started then + match i.stack with + | MapOne (k, v) :: _ -> new KeyValuePair<_, _>(k, v) + | [] -> alreadyFinished() + | _ -> failwith "Please report error: Map iterator, unexpected stack for current" + else + notStarted() + + let rec moveNext i = + if i.started then + match i.stack with + | MapOne _ :: rest -> + i.stack <- collapseLHS rest + not i.stack.IsEmpty + | [] -> false + | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" + else + 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 + + 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() = ()} + +[>)>] +[] +[] +[] +[] +type Map<[]'Key, []'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key, 'Value>) = - let partition (comparer: IComparer<'Key>) f s = partitionAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s (empty,empty) +#if !FX_NO_BINARY_SERIALIZATION + [] + // 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 + + // This type is logically immutable. This field is only mutated during serialization and deserialization. + // + // WARNING: The compiled name of this field may never be changed because it is part of the logical + // WARNING: permanent serialization format for this type. + let mutable serializedData = null +#endif - let filter1 (comparer: IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v acc = if f.Invoke(k, v) then add comparer k v acc else acc + // 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 = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<'Key, 'Value>(comparer, MapTree<_, _>.MapEmpty) - let rec filterAux (comparer: IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = - match s with - | MapEmpty -> acc - | MapOne(k,v) -> filter1 comparer f k v acc - | MapNode(k,v,l,r,_) -> - let acc = filterAux comparer f l acc - let acc = filter1 comparer f k v acc - filterAux comparer f r acc +#if !FX_NO_BINARY_SERIALIZATION + [] + member __.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = + ignore(context) + serializedData <- MapTree.toArray tree |> Array.map (fun (k, v) -> KeyValuePair(k, v)) + + // Do not set this to null, since concurrent threads may also be serializing the data + //[] + //member __.OnSerialized(context: System.Runtime.Serialization.StreamingContext) = + // serializedData <- null + + [] + member __.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = + ignore(context) + comparer <- LanguagePrimitives.FastGenericComparer<'Key> + tree <- serializedData |> Array.map (fun (KeyValue(k, v)) -> (k, v)) |> MapTree.ofArray comparer + serializedData <- null +#endif - let filter (comparer: IComparer<'Key>) f s = filterAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s empty + static member Empty : Map<'Key, 'Value> = + empty - let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = - match m with - | MapEmpty -> failwith "internal error: Map.spliceOutSuccessor" - | MapOne(k2,v2) -> k2,v2,MapEmpty - | MapNode(k2,v2,l,r,_) -> - match l with - | MapEmpty -> k2,v2,r - | _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r - - let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = - match m with - | MapEmpty -> empty - | MapOne(k2,_) -> - let c = comparer.Compare(k,k2) - if c = 0 then MapEmpty else m - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (remove comparer k l) k2 v2 r - elif c = 0 then - match l,r with - | MapEmpty,_ -> r - | _,MapEmpty -> l - | _ -> - let sk,sv,r' = spliceOutSuccessor r - mk l sk sv r' - else rebalance l k2 v2 (remove comparer k r) - - let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = - match m with - | MapEmpty -> false - | MapOne(k2,_) -> (comparer.Compare(k,k2) = 0) - | MapNode(k2,_,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then mem comparer k l - else (c = 0 || mem comparer k r) - - let rec iterOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) (m: MapTree<'Key, 'Value>) = - match m with - | MapEmpty -> () - | MapOne(k2,v2) -> f.Invoke(k2, v2) - | MapNode(k2,v2,l,r,_) -> iterOpt f l; f.Invoke(k2, v2); iterOpt f r + static member Create(ie : IEnumerable<_>) : Map<'Key, 'Value> = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofSeq comparer ie) - let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m + new (elements : seq<_>) = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofSeq comparer elements) - let rec tryPickOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = - match m with - | MapEmpty -> None - | MapOne(k2,v2) -> f.Invoke(k2, v2) - | MapNode(k2,v2,l,r,_) -> - match tryPickOpt f l with - | Some _ as res -> res - | None -> - match f.Invoke(k2, v2) with - | Some _ as res -> res - | None -> - tryPickOpt f r - - let tryPick f m = tryPickOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m - - let rec existsOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = - match m with - | MapEmpty -> false - | MapOne(k2,v2) -> f.Invoke(k2, v2) - | MapNode(k2,v2,l,r,_) -> existsOpt f l || f.Invoke(k2, v2) || existsOpt f r + [] + member internal m.Comparer = comparer - let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m + //[] + member internal m.Tree = tree - let rec forallOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = - match m with - | MapEmpty -> true - | MapOne(k2,v2) -> f.Invoke(k2, v2) - | MapNode(k2,v2,l,r,_) -> forallOpt f l && f.Invoke(k2, v2) && forallOpt f r + member m.Add(key, value) : Map<'Key, 'Value> = +#if TRACE_SETS_AND_MAPS + 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 + MapTree.largestMapSize <- size + MapTree.largestMapStackTrace <- System.Diagnostics.StackTrace().ToString() +#endif + new Map<'Key, 'Value>(comparer, MapTree.add comparer key value tree) - let forall f m = forallOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m + [] + member m.IsEmpty = MapTree.isEmpty tree - let rec map f m = - match m with - | MapEmpty -> empty - | MapOne(k,v) -> MapOne(k,f v) - | MapNode(k,v,l,r,h) -> - let l2 = map f l - let v2 = f v - let r2 = map f r - MapNode(k,v2,l2, r2,h) - - let rec mapiOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = - match m with - | MapEmpty -> empty - | MapOne(k,v) -> MapOne(k, f.Invoke(k, v)) - | MapNode(k,v,l,r,h) -> - let l2 = mapiOpt f l - let v2 = f.Invoke(k, v) - let r2 = mapiOpt f r - MapNode(k,v2, l2, r2,h) - - let mapi f m = mapiOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m - - let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = - match m with - | MapEmpty -> x - | MapOne(k,v) -> f.Invoke(k,v,x) - | MapNode(k,v,l,r,_) -> - let x = foldBackOpt f r x - let x = f.Invoke(k,v,x) - foldBackOpt f l x + 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) +#endif + MapTree.find comparer key tree - let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) m x + member m.TryPick f = + MapTree.tryPick f tree - let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) x m = - match m with - | MapEmpty -> x - | MapOne(k,v) -> f.Invoke(x,k,v) - | MapNode(k,v,l,r,_) -> - let x = foldOpt f x l - let x = f.Invoke(x,k,v) - foldOpt f x r - - let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) x m - - let foldSectionOpt (comparer: IComparer<'Key>) lo hi (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = - let rec foldFromTo (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = - match m with - | MapEmpty -> x - | MapOne(k,v) -> - let cLoKey = comparer.Compare(lo,k) - let cKeyHi = comparer.Compare(k,hi) - let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke(k, v, x) else x - x - | MapNode(k,v,l,r,_) -> - let cLoKey = comparer.Compare(lo,k) - let cKeyHi = comparer.Compare(k,hi) - let x = if cLoKey < 0 then foldFromTo f l x else x - let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke(k, v, x) else x - let x = if cKeyHi < 0 then foldFromTo f r 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 = - let rec loop m acc = - match m with - | MapEmpty -> acc - | MapOne(k,v) -> (k,v)::acc - | MapNode(k,v,l,r,_) -> loop l ((k,v)::loop r acc) - loop m [] - let toArray m = m |> toList |> Array.ofList - 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 - mkFromEnumerator comparer (add comparer x y acc) e - else acc - - let ofArray comparer (arr : array<_>) = - let mutable res = empty - for (x,y) in arr do - res <- add comparer x y res - res - - let ofSeq comparer (c : seq<'Key * 'T>) = - match c with - | :? array<'Key * 'T> as xs -> ofArray comparer xs - | :? list<'Key * 'T> as xs -> ofList comparer xs - | _ -> - use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie - - - let copyToArray s (arr: _[]) i = - let j = ref i - s |> 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; - /// 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 = - match stack with - | [] -> [] - | MapEmpty :: rest -> collapseLHS rest - | MapOne _ :: _ -> stack - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest) - - let mkIterator s = { stack = collapseLHS [s]; started = false } - - let notStarted() = raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) - - let current i = - if i.started then - match i.stack with - | MapOne (k,v) :: _ -> new KeyValuePair<_,_>(k,v) - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Map iterator, unexpected stack for current" - else - notStarted() - - let rec moveNext i = - if i.started then - match i.stack with - | MapOne _ :: rest -> i.stack <- collapseLHS rest - not i.stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" - else - i.started <- true (* The first call to MoveNext "starts" the enumeration. *) - not i.stack.IsEmpty - - let mkIEnumerator s = - let i = ref (mkIterator s) - { 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 s - interface System.IDisposable with - member __.Dispose() = ()} - - - - [>)>] - [] - [] - [] - [] - type Map<[]'Key,[]'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key,'Value>) = + member m.Exists predicate = + MapTree.exists predicate tree -#if !FX_NO_BINARY_SERIALIZATION - [] - // 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 - - // This type is logically immutable. This field is only mutated during serialization and deserialization. - // - // WARNING: The compiled name of this field may never be changed because it is part of the logical - // WARNING: permanent serialization format for this type. - let mutable serializedData = null -#endif + member m.Filter predicate = + new Map<'Key, 'Value>(comparer, MapTree.filter comparer predicate tree) - // 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 = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<'Key,'Value>(comparer,MapTree<_,_>.MapEmpty) + member m.ForAll predicate = + MapTree.forall predicate tree -#if !FX_NO_BINARY_SERIALIZATION - [] - member __.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = - ignore(context) - serializedData <- MapTree.toArray tree |> Array.map (fun (k,v) -> KeyValuePair(k,v)) - - // Do not set this to null, since concurrent threads may also be serializing the data - //[] - //member __.OnSerialized(context: System.Runtime.Serialization.StreamingContext) = - // serializedData <- null - - [] - member __.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = - ignore(context) - comparer <- LanguagePrimitives.FastGenericComparer<'Key> - tree <- serializedData |> Array.map (fun (KeyValue(k,v)) -> (k,v)) |> MapTree.ofArray comparer - serializedData <- null -#endif + member m.Fold f acc = + MapTree.foldBack f tree acc - static member Empty : Map<'Key,'Value> = empty + member m.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = + MapTree.foldSection comparer lo hi f tree acc - static member Create(ie : IEnumerable<_>) : Map<'Key,'Value> = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_,_>(comparer,MapTree.ofSeq comparer ie) - - static member Create() : Map<'Key,'Value> = empty + member m.Iterate f = + MapTree.iter f tree - new(elements : seq<_>) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_,_>(comparer,MapTree.ofSeq comparer elements) - - [] - member internal m.Comparer = comparer + member m.MapRange f = + new Map<'Key, 'b>(comparer, MapTree.map f tree) - //[] - member internal m.Tree = tree + member m.Map f = + new Map<'Key, 'b>(comparer, MapTree.mapi f tree) - member m.Add(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.ContainsKey(key) = #if TRACE_SETS_AND_MAPS - 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 - MapTree.largestMapSize <- size - MapTree.largestMapStackTrace <- System.Diagnostics.StackTrace().ToString() + MapTree.report() + MapTree.numLookups <- MapTree.numLookups + 1 + MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) #endif - new Map<'Key,'Value>(comparer,MapTree.add comparer key value tree) + MapTree.mem comparer key tree - [] - member m.IsEmpty = MapTree.isEmpty tree + member m.Remove key = + new Map<'Key, 'Value>(comparer, MapTree.remove comparer key tree) - member m.Item - with get(key : 'Key) = + member m.TryGetValue(key, [] value: byref<'Value>) = + MapTree.tryGetValue comparer key &value tree + + member m.TryFind(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.tryFind comparer key tree + + member m.ToList() = + MapTree.toList tree + + member m.ToArray() = + MapTree.toArray tree + + 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 + let mutable res = 0 + 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() + let m2 = e2.MoveNext() + (m1 = m2) && (not m1 || + (let e1c, e2c = e1.Current, e2.Current + ((e1c.Key = e2c.Key) && (Unchecked.equals e1c.Value e2c.Value) && loop()))) + loop() + | _ -> false + + override this.GetHashCode() = this.ComputeHashCode() + + interface IEnumerable> with + member __.GetEnumerator() = MapTree.mkIEnumerator tree + + interface System.Collections.IEnumerable with + member __.GetEnumerator() = (MapTree.mkIEnumerator tree :> System.Collections.IEnumerator) + + interface IDictionary<'Key, 'Value> with + member m.Item + with get x = m.[x] + and set x v = ignore(x, v); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.TryPick(f) = MapTree.tryPick f tree + // REVIEW: this implementation could avoid copying the Values to an array + member m.Keys = ([| for kvp in m -> kvp.Key |] :> ICollection<'Key>) - member m.Exists(f) = MapTree.exists f tree + // REVIEW: this implementation could avoid copying the Values to an array + member m.Values = ([| for kvp in m -> kvp.Value |] :> ICollection<'Value>) - member m.Filter(f) : Map<'Key,'Value> = new Map<'Key,'Value>(comparer,MapTree.filter comparer f tree) + member m.Add(k, v) = ignore(k, v); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.ForAll(f) = MapTree.forall f tree + member m.ContainsKey(k) = m.ContainsKey(k) - member m.Fold f acc = MapTree.foldBack f tree acc + member m.TryGetValue(k, r) = m.TryGetValue(k, &r) - member m.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = MapTree.foldSection comparer lo hi f tree acc + member m.Remove(k : 'Key) = ignore(k); (raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) : bool) - member m.Iterate f = MapTree.iter f tree + interface ICollection> with + member __.Add(x) = ignore(x); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.MapRange f = new Map<'Key,'b>(comparer,MapTree.map f tree) + member __.Clear() = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.Map f = new Map<'Key,'b>(comparer,MapTree.mapi f tree) + member __.Remove(x) = ignore(x); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member m.Partition(f) : Map<'Key,'Value> * Map<'Key,'Value> = - let r1,r2 = MapTree.partition comparer f tree in - new Map<'Key,'Value>(comparer,r1), new Map<'Key,'Value>(comparer,r2) + member m.Contains(x) = m.ContainsKey(x.Key) && Unchecked.equals m.[x.Key] x.Value - member m.Count = MapTree.size tree + member __.CopyTo(arr, i) = MapTree.copyToArray tree arr i - member m.ContainsKey(key) = -#if TRACE_SETS_AND_MAPS - MapTree.report() - MapTree.numLookups <- MapTree.numLookups + 1 - MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) -#endif - MapTree.mem comparer key tree + member __.IsReadOnly = true - member m.Remove(key) : Map<'Key,'Value> = - new Map<'Key,'Value>(comparer,MapTree.remove comparer key tree) + member m.Count = m.Count - member m.TryGetValue(key, [] value:byref<'Value>) = - MapTree.tryGetValue comparer key &value tree + 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)) - member m.TryFind(key) = -#if TRACE_SETS_AND_MAPS - MapTree.report() - MapTree.numLookups <- MapTree.numLookups + 1 - MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) -#endif - MapTree.tryFind comparer key tree - - member m.ToList() = MapTree.toList tree - - member m.ToArray() = MapTree.toArray tree - - 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 - let mutable res = 0 - 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() - let m2 = e2.MoveNext() - (m1 = m2) && (not m1 || let e1c, e2c = e1.Current, e2.Current in ((e1c.Key = e2c.Key) && (Unchecked.equals e1c.Value e2c.Value) && loop())) - loop() - | _ -> false - - override this.GetHashCode() = this.ComputeHashCode() - - interface IEnumerable> with - member __.GetEnumerator() = MapTree.mkIEnumerator tree - - interface System.Collections.IEnumerable with - member __.GetEnumerator() = (MapTree.mkIEnumerator tree :> System.Collections.IEnumerator) - - interface IDictionary<'Key, 'Value> with - member m.Item - with get x = m.[x] - and set x v = ignore(x,v); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - - // REVIEW: this implementation could avoid copying the Values to an array - member s.Keys = ([| for kvp in s -> kvp.Key |] :> ICollection<'Key>) - - // REVIEW: this implementation could avoid copying the Values to an array - member s.Values = ([| for kvp in s -> kvp.Value |] :> ICollection<'Value>) - - member s.Add(k,v) = ignore(k,v); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) - member s.ContainsKey(k) = s.ContainsKey(k) - member s.TryGetValue(k,r) = s.TryGetValue(k,&r) - member s.Remove(k : 'Key) = ignore(k); (raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) : bool) - - interface ICollection> with - member __.Add(x) = ignore(x); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))); - member __.Clear() = raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))); - member __.Remove(x) = ignore(x); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))); - member s.Contains(x) = s.ContainsKey(x.Key) && Unchecked.equals s.[x.Key] x.Value - member __.CopyTo(arr,i) = MapTree.copyToArray tree arr i - member s.IsReadOnly = true - member s.Count = s.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 IReadOnlyCollection> with - member s.Count = s.Count - - interface IReadOnlyDictionary<'Key, 'Value> with - member s.Item with get(key) = s.[key] - member s.Keys = seq { for kvp in s -> kvp.Key } - member s.TryGetValue(key, value:byref<'Value>) = s.TryGetValue(key, &value) - member s.Values = seq { for kvp in s -> kvp.Value } - member s.ContainsKey key = s.ContainsKey key - - override x.ToString() = - match List.ofSeq (Seq.truncate 4 x) with - | [] -> "map []" - | [KeyValue h1] -> System.Text.StringBuilder().Append("map [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("]").ToString() - | [KeyValue h1;KeyValue h2] -> System.Text.StringBuilder().Append("map [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h2).Append("]").ToString() - | [KeyValue h1;KeyValue h2;KeyValue h3] -> System.Text.StringBuilder().Append("map [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h2).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h3).Append("]").ToString() - | KeyValue h1 :: KeyValue h2 :: KeyValue h3 :: _ -> System.Text.StringBuilder().Append("map [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h2).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h3).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 - - and - [] - KeyValuePairDebugFriendly<'Key,'Value>(keyValue : KeyValuePair<'Key, 'Value>) = - - [] - member x.KeyValue = keyValue - + interface IReadOnlyCollection> with + member m.Count = m.Count -namespace Microsoft.FSharp.Collections + interface IReadOnlyDictionary<'Key, 'Value> with + + member m.Item with get(key) = m.[key] + + member m.Keys = seq { for kvp in m -> kvp.Key } - open System - open System.Diagnostics - open System.Collections.Generic - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Collections + member m.TryGetValue(key, value: byref<'Value>) = m.TryGetValue(key, &value) - [] - [] - module Map = + member m.Values = seq { for kvp in m -> kvp.Value } - [] - let isEmpty (table:Map<_,_>) = table.IsEmpty + member m.ContainsKey key = m.ContainsKey key + + override x.ToString() = + match List.ofSeq (Seq.truncate 4 x) with + | [] -> "map []" + | [KeyValue h1] -> + let txt1 = LanguagePrimitives.anyToStringShowingNull h1 + StringBuilder().Append("map [").Append(txt1).Append("]").ToString() + | [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] -> + 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() + | 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>) = - [] - let add key value (table:Map<_,_>) = table.Add(key,value) + [] + member x.Items = + v |> Seq.truncate 10000 |> Seq.map KeyValuePairDebugFriendly |> Seq.toArray - [] - let find key (table:Map<_,_>) = table.[key] +and + [] + KeyValuePairDebugFriendly<'Key, 'Value>(keyValue : KeyValuePair<'Key, 'Value>) = - [] - let tryFind key (table:Map<_,_>) = table.TryFind(key) + [] + member x.KeyValue = keyValue - [] - let remove key (table:Map<_,_>) = table.Remove(key) +[] +[] +module Map = - [] - let containsKey key (table:Map<_,_>) = table.ContainsKey(key) + [] + let isEmpty (table: Map<_, _>) = + table.IsEmpty - [] - let iter action (table:Map<_,_>) = table.Iterate(action) + [] + let add key value (table: Map<_, _>) = + table.Add (key, value) - [] - let tryPick chooser (table:Map<_,_>) = table.TryPick(chooser) + [] + let find key (table: Map<_, _>) = + table.[key] - [] - let pick chooser (table:Map<_,_>) = match tryPick chooser table with None -> raise (KeyNotFoundException()) | Some res -> res + [] + let tryFind key (table: Map<_, _>) = + table.TryFind key - [] - let exists predicate (table:Map<_,_>) = table.Exists(predicate) + [] + let remove key (table: Map<_, _>) = + table.Remove key - [] - let filter predicate (table:Map<_,_>) = table.Filter(predicate) + [] + let containsKey key (table: Map<_, _>) = + table.ContainsKey key - [] - let partition predicate (table:Map<_,_>) = table.Partition(predicate) + [] + let iter action (table: Map<_, _>) = + table.Iterate action - [] - let forall predicate (table:Map<_,_>) = table.ForAll(predicate) + [] + let tryPick chooser (table: Map<_, _>) = + table.TryPick chooser - let mapRange f (m:Map<_,_>) = m.MapRange(f) + [] + let pick chooser (table: Map<_, _>) = + match tryPick chooser table with + | None -> raise (KeyNotFoundException()) + | Some res -> res - [] - let map mapping (table:Map<_,_>) = table.Map(mapping) + [] + let exists predicate (table: Map<_, _>) = + table.Exists predicate - [] - let fold<'Key,'T,'State when 'Key : comparison> folder (state:'State) (table:Map<'Key,'T>) = MapTree.fold folder state table.Tree + [] + let filter predicate (table: Map<_, _>) = + table.Filter predicate - [] - let foldBack<'Key,'T,'State when 'Key : comparison> folder (table:Map<'Key,'T>) (state:'State) = MapTree.foldBack folder table.Tree state - - [] - let toSeq (table:Map<_,_>) = table |> Seq.map (fun kvp -> kvp.Key, kvp.Value) + [] + let partition predicate (table: Map<_, _>) = + table.Partition predicate - [] - let findKey predicate (table : Map<_,_>) = table |> toSeq |> Seq.pick (fun (k,v) -> if predicate k v then Some(k) else None) + [] + let forall predicate (table: Map<_, _>) = + table.ForAll predicate - [] - let tryFindKey predicate (table : Map<_,_>) = table |> toSeq |> Seq.tryPick (fun (k,v) -> if predicate k v then Some(k) else None) + [] + let map mapping (table: Map<_, _>) = + table.Map mapping - [] - let ofList (elements: ('Key * 'Value) list) = Map<_,_>.ofList(elements) + [] + let fold<'Key, 'T, 'State when 'Key : comparison> folder (state:'State) (table: Map<'Key, 'T>) = + MapTree.fold folder state table.Tree - [] - let ofSeq elements = Map<_,_>.Create(elements) + [] + let foldBack<'Key, 'T, 'State when 'Key : comparison> folder (table: Map<'Key, 'T>) (state:'State) = + MapTree.foldBack folder table.Tree state - [] - let ofArray (elements: ('Key * 'Value) array) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_,_>(comparer,MapTree.ofArray comparer elements) + [] + let toSeq (table: Map<_, _>) = + table |> Seq.map (fun kvp -> kvp.Key, kvp.Value) - [] - let toList (table:Map<_,_>) = table.ToList() + [] + let findKey predicate (table : Map<_, _>) = + table |> toSeq |> Seq.pick (fun (k, v) -> if predicate k v then Some(k) else None) - [] - let toArray (table:Map<_,_>) = table.ToArray() + [] + let tryFindKey predicate (table : Map<_, _>) = + table |> toSeq |> Seq.tryPick (fun (k, v) -> if predicate k v then Some(k) else None) - [] - let empty<'Key,'Value when 'Key : comparison> = Map<'Key,'Value>.Empty + [] + let ofList (elements: ('Key * 'Value) list) = + Map<_, _>.ofList(elements) - [] - let count (table:Map<_,_>) = table.Count + [] + let ofSeq elements = + Map<_, _>.Create(elements) + + [] + let ofArray (elements: ('Key * 'Value) array) = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofArray comparer elements) + + [] + let toList (table: Map<_, _>) = + table.ToList() + + [] + let toArray (table: Map<_, _>) = + table.ToArray() + + [] + let empty<'Key, 'Value when 'Key : comparison> = + Map<'Key, 'Value>.Empty + + [] + let count (table: Map<_, _>) = + table.Count diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 7bdf69c2924..13db8650520 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -6,8 +6,8 @@ #nowarn "52" // The value has been copied to ensure the original is not mutated by this operation #nowarn "60" // Override implementations in augmentations are now deprecated. Override implementations should be given as part of the initial declaration of a type. #nowarn "61" // The containing type can use 'null' as a representation value for its nullary union case. This member will be compiled as a static member. -#nowarn "69" // Interface implementations in augmentations are now deprecated. Interface implementations should be given on the initial declaration of a type. -#nowarn "77" // Member constraints with the name 'Exp' are given special status by the F# compiler as certain .NET types are implicitly augmented with this member. This may result in compilation failures if you attempt to invoke the member constraint from your own code. +#nowarn "69" // Interface implementations in augmentations are now deprecated. Interface implementations should be given on the initial declaration... +#nowarn "77" // Member constraints with the name 'Exp' are given special status by the F# compiler... #nowarn "3218" // mismatch of parameter name for 'fst' and 'snd' namespace Microsoft.FSharp.Core @@ -53,152 +53,152 @@ namespace Microsoft.FSharp.Core | UseNullAsTrueValue = 8 | Event = 16 - [] + [] type SealedAttribute(value:bool) = inherit System.Attribute() member x.Value = value new() = new SealedAttribute(true) - [] + [] [] type AbstractClassAttribute() = inherit System.Attribute() - [] + [] [] type EqualityConditionalOnAttribute() = inherit System.Attribute() - [] + [] [] type ComparisonConditionalOnAttribute() = inherit System.Attribute() - [] + [] [] type AllowNullLiteralAttribute(value: bool) = inherit System.Attribute() member x.Value = value new () = new AllowNullLiteralAttribute(true) - [] + [] [] type VolatileFieldAttribute() = inherit System.Attribute() - [] + [] [] type DefaultAugmentationAttribute(value:bool) = inherit System.Attribute() member x.Value = value - [] + [] [] type CLIEventAttribute() = inherit System.Attribute() - [] + [] [] type CLIMutableAttribute() = inherit System.Attribute() - [] + [] [] type AutoSerializableAttribute(value:bool) = inherit System.Attribute() member x.Value = value - [] + [] [] type DefaultValueAttribute(check:bool) = inherit System.Attribute() member x.Check = check new() = new DefaultValueAttribute(true) - [] + [] [] type EntryPointAttribute() = inherit System.Attribute() - [] + [] [] type ReferenceEqualityAttribute() = inherit System.Attribute() - [] + [] [] type StructuralComparisonAttribute() = inherit System.Attribute() - [] + [] [] type StructuralEqualityAttribute() = inherit System.Attribute() - [] + [] [] type NoEqualityAttribute() = inherit System.Attribute() - [] + [] [] type CustomEqualityAttribute() = inherit System.Attribute() - [] + [] [] type CustomComparisonAttribute() = inherit System.Attribute() - [] + [] [] type NoComparisonAttribute() = inherit System.Attribute() - [] + [] [] type ReflectedDefinitionAttribute(includeValue: bool) = inherit System.Attribute() new() = ReflectedDefinitionAttribute(false) member x.IncludeValue = includeValue - [] + [] [] type CompiledNameAttribute(compiledName:string) = inherit System.Attribute() member x.CompiledName = compiledName - [] + [] [] type StructAttribute() = inherit System.Attribute() - [] + [] [] type MeasureAttribute() = inherit System.Attribute() - [] + [] [] type MeasureAnnotatedAbbreviationAttribute() = inherit System.Attribute() - [] + [] [] type InterfaceAttribute() = inherit System.Attribute() - [] + [] [] type ClassAttribute() = inherit System.Attribute() - [] + [] [] type LiteralAttribute() = inherit System.Attribute() - [] + [] [] type FSharpInterfaceDataVersionAttribute(major:int,minor:int,release:int) = inherit System.Attribute() @@ -206,7 +206,7 @@ namespace Microsoft.FSharp.Core member x.Minor = minor member x.Release = release - [] + [] [] type CompilationMappingAttribute(sourceConstructFlags:SourceConstructFlags, variantNumber:int, @@ -224,26 +224,26 @@ namespace Microsoft.FSharp.Core member x.TypeDefinitions = typeDefinitions member x.ResourceName = resourceName - [] + [] [] type CompilationSourceNameAttribute(sourceName:string) = inherit System.Attribute() member x.SourceName = sourceName //------------------------------------------------------------------------- - [] + [] [] type CompilationRepresentationAttribute (flags : CompilationRepresentationFlags) = inherit System.Attribute() member x.Flags = flags - [] + [] [] type ExperimentalAttribute(message:string) = inherit System.Attribute() member x.Message = message - [] + [] [] type CompilationArgumentCountsAttribute(counts:int[]) = inherit System.Attribute() @@ -251,7 +251,7 @@ namespace Microsoft.FSharp.Core let unboxPrim(x:obj) = (# "unbox.any !0" type ('T) x : 'T #) (unboxPrim(counts.Clone()) : System.Collections.Generic.IEnumerable) - [] + [] [] type CustomOperationAttribute(name:string) = inherit System.Attribute() @@ -272,18 +272,18 @@ namespace Microsoft.FSharp.Core member x.MaintainsVariableSpace with get() = maintainsVarSpace and set v = maintainsVarSpace <- v member x.MaintainsVariableSpaceUsingBind with get() = maintainsVarSpaceWithBind and set v = maintainsVarSpaceWithBind <- v - [] + [] [] type ProjectionParameterAttribute() = inherit System.Attribute() - [] + [] [] type StructuredFormatDisplayAttribute(value:string) = inherit System.Attribute() member x.Value = value - [] + [] [] type CompilerMessageAttribute(message:string, messageNumber : int) = inherit System.Attribute() @@ -294,37 +294,37 @@ namespace Microsoft.FSharp.Core member x.IsError with get() = isError and set v = isError <- v member x.IsHidden with get() = isHidden and set v = isHidden <- v - [] + [] [] type UnverifiableAttribute() = inherit System.Attribute() - [] + [] [] type NoDynamicInvocationAttribute() = inherit System.Attribute() - [] + [] [] type OptionalArgumentAttribute() = inherit System.Attribute() - [] + [] [] type GeneralizableValueAttribute() = inherit System.Attribute() - [] + [] [] type RequiresExplicitTypeArgumentsAttribute() = inherit System.Attribute() - [] + [] [] type RequireQualifiedAccessAttribute() = inherit System.Attribute() - [] + [] [] type AutoOpenAttribute(path:string) = inherit System.Attribute() @@ -334,7 +334,7 @@ namespace Microsoft.FSharp.Core /// This Attribute is used to make Value bindings like /// let x = some code /// operate like static properties. - [] + [] [] type ValueAsStaticPropertyAttribute() = inherit System.Attribute() @@ -1900,7 +1900,9 @@ namespace Microsoft.FSharp.Core // Because the function subsequently gets inlined, the calls to GenericHashWithComparerFast can be // often statically optimized or devirtualized based on the statically known type. let inline FastHashTuple2 (comparer:System.Collections.IEqualityComparer) (x1,x2) = - TupleUtils.combineTupleHashes (GenericHashWithComparerFast comparer x1) (GenericHashWithComparerFast comparer x2) + TupleUtils.combineTupleHashes + (GenericHashWithComparerFast comparer x1) + (GenericHashWithComparerFast comparer x2) /// Compiler intrinsic generated for devirtualized calls to structural hashing on tuples. // @@ -1910,7 +1912,11 @@ namespace Microsoft.FSharp.Core // Because the function subsequently gets inlined, the calls to GenericHashWithComparerFast can be // often statically optimized or devirtualized based on the statically known type. let inline FastHashTuple3 (comparer:System.Collections.IEqualityComparer) (x1,x2,x3) = - TupleUtils.combineTupleHashes (TupleUtils.combineTupleHashes (GenericHashWithComparerFast comparer x1) (GenericHashWithComparerFast comparer x2)) (GenericHashWithComparerFast comparer x3) + TupleUtils.combineTupleHashes + (TupleUtils.combineTupleHashes + (GenericHashWithComparerFast comparer x1) + (GenericHashWithComparerFast comparer x2)) + (GenericHashWithComparerFast comparer x3) /// Compiler intrinsic generated for devirtualized calls to structural hashing on tuples. // @@ -1920,7 +1926,13 @@ namespace Microsoft.FSharp.Core // Because the function subsequently gets inlined, the calls to GenericHashWithComparerFast can be // often statically optimized or devirtualized based on the statically known type. let inline FastHashTuple4 (comparer:System.Collections.IEqualityComparer) (x1,x2,x3,x4) = - TupleUtils.combineTupleHashes (TupleUtils.combineTupleHashes (GenericHashWithComparerFast comparer x1) (GenericHashWithComparerFast comparer x2)) (TupleUtils.combineTupleHashes (GenericHashWithComparerFast comparer x3) (GenericHashWithComparerFast comparer x4)) + TupleUtils.combineTupleHashes + (TupleUtils.combineTupleHashes + (GenericHashWithComparerFast comparer x1) + (GenericHashWithComparerFast comparer x2)) + (TupleUtils.combineTupleHashes + (GenericHashWithComparerFast comparer x3) + (GenericHashWithComparerFast comparer x4)) /// Compiler intrinsic generated for devirtualized calls to structural hashing on tuples. // @@ -1930,7 +1942,15 @@ namespace Microsoft.FSharp.Core // Because the function subsequently gets inlined, the calls to GenericHashWithComparerFast can be // often statically optimized or devirtualized based on the statically known type. let inline FastHashTuple5 (comparer:System.Collections.IEqualityComparer) (x1,x2,x3,x4,x5) = - TupleUtils.combineTupleHashes (TupleUtils.combineTupleHashes (TupleUtils.combineTupleHashes (GenericHashWithComparerFast comparer x1) (GenericHashWithComparerFast comparer x2)) (TupleUtils.combineTupleHashes (GenericHashWithComparerFast comparer x3) (GenericHashWithComparerFast comparer x4))) (GenericHashWithComparerFast comparer x5) + TupleUtils.combineTupleHashes + (TupleUtils.combineTupleHashes + (TupleUtils.combineTupleHashes + (GenericHashWithComparerFast comparer x1) + (GenericHashWithComparerFast comparer x2)) + (TupleUtils.combineTupleHashes + (GenericHashWithComparerFast comparer x3) + (GenericHashWithComparerFast comparer x4))) + (GenericHashWithComparerFast comparer x5) /// Compiler intrinsic generated for devirtualized calls to PER-semantic structural equality on tuples // diff --git a/src/fsharp/FSharp.Core/printf.fs b/src/fsharp/FSharp.Core/printf.fs index 0c2d6b70316..eb0996da06d 100644 --- a/src/fsharp/FSharp.Core/printf.fs +++ b/src/fsharp/FSharp.Core/printf.fs @@ -62,7 +62,7 @@ module internal PrintfImpl = | PlusForPositives = 4 | SpaceForPositives = 8 - let inline hasFlag flags (expected : FormatFlags) = (flags &&& expected) = expected + let inline hasFlag flags (expected: FormatFlags) = (flags &&& expected) = expected let inline isLeftJustify flags = hasFlag flags FormatFlags.LeftJustify let inline isPadWithZeros flags = hasFlag flags FormatFlags.PadWithZeros let inline isPlusForPositives flags = hasFlag flags FormatFlags.PlusForPositives @@ -79,10 +79,10 @@ module internal PrintfImpl = [] type FormatSpecifier = { - TypeChar : char - Precision : int - Width : int - Flags : FormatFlags + TypeChar: char + Precision: int + Width: int + Flags: FormatFlags } member this.IsStarPrecision = this.Precision = StarValue member this.IsPrecisionSpecified = this.Precision <> NotSpecifiedValue @@ -102,8 +102,10 @@ module internal PrintfImpl = /// Set of helpers to parse format string module private FormatString = + let inline isDigit c = c >= '0' && c <= '9' - let intFromString (s : string) pos = + + let intFromString (s: string) pos = let rec go acc i = if isDigit s.[i] then let n = int s.[i] - int '0' @@ -111,7 +113,7 @@ module internal PrintfImpl = else acc, i go 0 pos - let parseFlags (s : string) i : FormatFlags * int = + let parseFlags (s: string) i = let rec go flags i = match s.[i] with | '0' -> go (flags ||| FormatFlags.PadWithZeros) (i + 1) @@ -121,23 +123,23 @@ module internal PrintfImpl = | _ -> flags, i go FormatFlags.None i - let parseWidth (s : string) i : int * int = + let parseWidth (s: string) i = if s.[i] = '*' then StarValue, (i + 1) elif isDigit (s.[i]) then intFromString s i else NotSpecifiedValue, i - let parsePrecision (s : string) i : int * int = + let parsePrecision (s: string) i = if s.[i] = '.' then if s.[i + 1] = '*' then StarValue, i + 2 elif isDigit (s.[i + 1]) then intFromString s (i + 1) else raise (ArgumentException("invalid precision value")) else NotSpecifiedValue, i - let parseTypeChar (s : string) i : char * int = + let parseTypeChar (s: string) i = s.[i], (i + 1) - let findNextFormatSpecifier (s : string) i = - let rec go i (buf : Text.StringBuilder) = + let findNextFormatSpecifier (s: string) i = + let rec go i (buf: Text.StringBuilder) = if i >= s.Length then s.Length, buf.ToString() else @@ -165,44 +167,44 @@ module internal PrintfImpl = /// Abstracts generated printer from the details of particular environment: how to write text, how to produce results etc... [] type PrintfEnv<'State, 'Residue, 'Result> = - val State : 'State - new(s : 'State) = { State = s } - abstract Finish : unit -> 'Result - abstract Write : string -> unit - abstract WriteT : 'Residue -> unit + val State: 'State + new(s: 'State) = { State = s } + abstract Finish: unit -> 'Result + abstract Write: string -> unit + abstract WriteT: 'Residue -> unit type Utils = - static member inline Write (env : PrintfEnv<_, _, _>, a, b) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b) = env.Write a env.Write b - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c) = Utils.Write(env, a, b) env.Write c - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d) = Utils.Write(env, a, b) Utils.Write(env, c, d) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e) = Utils.Write(env, a, b, c) Utils.Write(env, d, e) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f) = Utils.Write(env, a, b, c, d) Utils.Write(env, e, f) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f, g) = Utils.Write(env, a, b, c, d, e) Utils.Write(env, f, g) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h) = Utils.Write(env, a, b, c, d, e, f) Utils.Write(env, g, h) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i) = Utils.Write(env, a, b, c, d, e, f, g) Utils.Write(env, h, i) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j) = Utils.Write(env, a, b, c, d, e, f, g, h) Utils.Write(env, i, j) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j, k) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j, k) = Utils.Write(env, a, b, c, d, e, f, g, h, i) Utils.Write(env, j, k) - static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j, k, l, m) = + static member inline Write (env: PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j, k, l, m) = Utils.Write(env, a, b, c, d, e, f, g, h, i, j, k) Utils.Write(env, l, m) @@ -225,8 +227,8 @@ module internal PrintfImpl = ( s0, conv1, s1 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) -> let env = env() Utils.Write(env, s0, (conv1 a), s1) env.Finish() @@ -237,8 +239,8 @@ module internal PrintfImpl = ( s0, conv1 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) -> let env = env() Utils.Write(env, s0, (conv1 a)) env.Finish() @@ -249,8 +251,8 @@ module internal PrintfImpl = ( conv1, s1 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) -> let env = env() Utils.Write(env, (conv1 a), s1) env.Finish() @@ -261,8 +263,8 @@ module internal PrintfImpl = ( conv1 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) -> let env = env() env.Write (conv1 a) env.Finish() @@ -273,8 +275,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) -> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2) env.Finish() @@ -285,8 +287,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) -> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b)) env.Finish() @@ -297,8 +299,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) -> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2) env.Finish() @@ -309,8 +311,8 @@ module internal PrintfImpl = ( conv1, s1, conv2 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) -> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b)) env.Finish() @@ -321,8 +323,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2, conv3, s3 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) -> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3) env.Finish() @@ -333,8 +335,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2, conv3 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) -> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c)) env.Finish() @@ -345,8 +347,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2, conv3, s3 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) -> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3) env.Finish() @@ -357,8 +359,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2, conv3 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) -> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c)) env.Finish() @@ -369,8 +371,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D)-> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4) env.Finish() @@ -381,8 +383,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2, conv3, s3, conv4 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D)-> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d)) env.Finish() @@ -393,8 +395,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2, conv3, s3, conv4, s4 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D)-> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4) env.Finish() @@ -405,8 +407,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2, conv3, s3, conv4 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D)-> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d)) env.Finish() @@ -417,8 +419,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5, s5 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D) (e: 'E)-> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e), s5) env.Finish() @@ -429,8 +431,8 @@ module internal PrintfImpl = ( s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D) (e: 'E)-> let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e)) env.Finish() @@ -441,8 +443,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5, s5 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D) (e: 'E)-> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e), s5) env.Finish() @@ -453,8 +455,8 @@ module internal PrintfImpl = ( conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5 ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D) (e: 'E)-> let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e)) env.Finish() @@ -466,8 +468,8 @@ module internal PrintfImpl = s0, conv1, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) -> let env() = let env = env() Utils.Write(env, s0, (conv1 a)) @@ -481,8 +483,8 @@ module internal PrintfImpl = conv1, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) -> let env() = let env = env() env.Write(conv1 a) @@ -496,8 +498,8 @@ module internal PrintfImpl = s0, conv1, s1, conv2, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) -> let env() = let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b)) @@ -511,8 +513,8 @@ module internal PrintfImpl = conv1, s1, conv2, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) -> let env() = let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b)) @@ -526,8 +528,8 @@ module internal PrintfImpl = s0, conv1, s1, conv2, s2, conv3, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) -> let env() = let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c)) @@ -541,8 +543,8 @@ module internal PrintfImpl = conv1, s1, conv2, s2, conv3, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) -> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) -> let env() = let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c)) @@ -556,8 +558,8 @@ module internal PrintfImpl = s0, conv1, s1, conv2, s2, conv3, s3, conv4, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D)-> let env() = let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d)) @@ -571,8 +573,8 @@ module internal PrintfImpl = conv1, s1, conv2, s2, conv3, s3, conv4, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D)-> let env() = let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d)) @@ -586,8 +588,8 @@ module internal PrintfImpl = s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D) (e: 'E)-> let env() = let env = env() Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e)) @@ -601,8 +603,8 @@ module internal PrintfImpl = conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5, next ) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)-> + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (a: 'A) (b: 'B) (c: 'C) (d: 'D) (e: 'E)-> let env() = let env = env() Utils.Write(env, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e)) @@ -611,9 +613,9 @@ module internal PrintfImpl = ) ) - static member TFinal(s1 : string, s2 : string) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (f : 'State -> 'Residue) -> + static member TFinal(s1: string, s2: string) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (f: 'State -> 'Residue) -> let env = env() env.Write(s1) env.WriteT(f env.State) @@ -621,21 +623,21 @@ module internal PrintfImpl = env.Finish() ) ) - static member TChained<'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (f : 'State -> 'Residue) -> + static member TChained<'Tail>(s1: string, next: PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (f: 'State -> 'Residue) -> let env() = let env = env() env.Write(s1) env.WriteT(f env.State) env - next(env) : 'Tail + next(env): 'Tail ) ) - static member LittleAFinal<'A>(s1 : string, s2 : string) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (f : 'State -> 'A ->'Residue) (a : 'A) -> + static member LittleAFinal<'A>(s1: string, s2: string) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (f: 'State -> 'A ->'Residue) (a: 'A) -> let env = env() env.Write s1 env.WriteT(f env.State a) @@ -643,31 +645,31 @@ module internal PrintfImpl = env.Finish() ) ) - static member LittleAChained<'A, 'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (f : 'State -> 'A ->'Residue) (a : 'A) -> + static member LittleAChained<'A, 'Tail>(s1: string, next: PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (f: 'State -> 'A ->'Residue) (a: 'A) -> let env() = let env = env() env.Write s1 env.WriteT(f env.State a) env - next env : 'Tail + next env: 'Tail ) ) - static member StarFinal1<'A>(s1 : string, conv, s2 : string) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (star1 : int) (a : 'A) -> + static member StarFinal1<'A>(s1: string, conv, s2: string) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (star1: int) (a: 'A) -> let env = env() env.Write s1 - env.Write (conv a star1 : string) + env.Write (conv a star1: string) env.Write s2 env.Finish() ) ) - static member PercentStarFinal1(s1 : string, s2 : string) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + static member PercentStarFinal1(s1: string, s2: string) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> (fun (_star1 : int) -> let env = env() env.Write s1 @@ -677,9 +679,9 @@ module internal PrintfImpl = ) ) - static member StarFinal2<'A>(s1 : string, conv, s2 : string) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (star1 : int) (star2 : int) (a : 'A) -> + static member StarFinal2<'A>(s1: string, conv, s2: string) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (star1: int) (star2: int) (a: 'A) -> let env = env() env.Write s1 env.Write (conv a star1 star2: string) @@ -689,8 +691,8 @@ module internal PrintfImpl = ) /// Handles case when '%*.*%' is used at the end of string - static member PercentStarFinal2(s1 : string, s2 : string) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + static member PercentStarFinal2(s1: string, s2: string) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> (fun (_star1 : int) (_star2 : int) -> let env = env() env.Write s1 @@ -700,9 +702,9 @@ module internal PrintfImpl = ) ) - static member StarChained1<'A, 'Tail>(s1 : string, conv, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (star1 : int) (a : 'A) -> + static member StarChained1<'A, 'Tail>(s1: string, conv, next: PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (star1: int) (a: 'A) -> let env() = let env = env() env.Write s1 @@ -713,21 +715,21 @@ module internal PrintfImpl = ) /// Handles case when '%*%' is used in the middle of the string so it needs to be chained to another printing block - static member PercentStarChained1<'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + static member PercentStarChained1<'Tail>(s1: string, next: PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> (fun (_star1 : int) -> let env() = let env = env() env.Write s1 env.Write("%") env - next env : 'Tail + next env: 'Tail ) ) - static member StarChained2<'A, 'Tail>(s1 : string, conv, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> - (fun (star1 : int) (star2 : int) (a : 'A) -> + static member StarChained2<'A, 'Tail>(s1: string, conv, next: PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (star1: int) (star2: int) (a: 'A) -> let env() = let env = env() env.Write s1 @@ -738,8 +740,8 @@ module internal PrintfImpl = ) /// Handles case when '%*.*%' is used in the middle of the string so it needs to be chained to another printing block - static member PercentStarChained2<'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = - (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + static member PercentStarChained2<'Tail>(s1: string, next: PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env: unit -> PrintfEnv<'State, 'Residue, 'Result>) -> (fun (_star1 : int) (_star2 : int) -> let env() = let env = env() @@ -762,7 +764,7 @@ module internal PrintfImpl = [] let DefaultPrecision = 6 - let getFormatForFloat (ch : char) (prec : int) = ch.ToString() + prec.ToString() + let getFormatForFloat (ch: char) (prec: int) = ch.ToString() + prec.ToString() let normalizePrecision prec = min (max prec 0) 99 /// Contains helpers to convert printer functions to functions that prints value with respect to specified justification @@ -776,7 +778,7 @@ module internal PrintfImpl = /// pad here is function that converts T to string with respect of justification /// basic - function that converts T to string without applying justification rules /// adaptPaddedFormatted returns boxed function that has various number of arguments depending on if width\precision flags has '*' value - let inline adaptPaddedFormatted (spec : FormatSpecifier) getFormat (basic : string -> 'T -> string) (pad : string -> int -> 'T -> string) = + let inline adaptPaddedFormatted (spec: FormatSpecifier) getFormat (basic: string -> 'T -> string) (pad: string -> int -> 'T -> string) = if spec.IsStarWidth then if spec.IsStarPrecision then // width=*, prec=* @@ -816,7 +818,7 @@ module internal PrintfImpl = /// pad here is function that converts T to string with respect of justification /// basic - function that converts T to string without applying justification rules /// adaptPadded returns boxed function that has various number of arguments depending on if width flags has '*' value - let inline adaptPadded (spec : FormatSpecifier) (basic : 'T -> string) (pad : int -> 'T -> string) = + let inline adaptPadded (spec: FormatSpecifier) (basic: 'T -> string) (pad: int -> 'T -> string) = if spec.IsStarWidth then // width=*, prec=? box(fun v width -> @@ -831,7 +833,7 @@ module internal PrintfImpl = box(fun v -> basic v) - let inline withPaddingFormatted (spec : FormatSpecifier) getFormat (defaultFormat : string) (f : string -> 'T -> string) left right = + let inline withPaddingFormatted (spec: FormatSpecifier) getFormat (defaultFormat: string) (f: string -> 'T -> string) left right = if not (spec.IsWidthSpecified || spec.IsPrecisionSpecified) then box (f defaultFormat) else @@ -840,7 +842,7 @@ module internal PrintfImpl = else adaptPaddedFormatted spec getFormat f right - let inline withPadding (spec : FormatSpecifier) (f : 'T -> string) left right = + let inline withPadding (spec: FormatSpecifier) (f: 'T -> string) left right = if not (spec.IsWidthSpecified) then box f else @@ -860,14 +862,13 @@ module internal PrintfImpl = /// contains functions to handle left\right justifications for non-numeric types (strings\bools) module Basic = - let inline leftJustify f padChar = - fun (w : int) v -> - (f v : string).PadRight(w, padChar) - - let inline rightJustify f padChar = - fun (w : int) v -> - (f v : string).PadLeft(w, padChar) + let inline leftJustify (f: 'T -> string) padChar = + fun (w: int) v -> + (f v).PadRight(w, padChar) + let inline rightJustify (f: 'T -> string) padChar = + fun (w: int) v -> + (f v).PadLeft(w, padChar) /// contains functions to handle left\right and no justification case for numbers module GenericNumber = @@ -875,7 +876,7 @@ module internal PrintfImpl = /// this case can be tricky: /// - negative numbers, -7 should be printed as '-007', not '00-7' /// - positive numbers when prefix for positives is set: 7 should be '+007', not '00+7' - let inline rightJustifyWithZeroAsPadChar (str : string) isNumber isPositive w (prefixForPositives : string) = + let inline rightJustifyWithZeroAsPadChar (str: string) isNumber isPositive w (prefixForPositives: string) = System.Diagnostics.Debug.Assert(prefixForPositives.Length = 0 || prefixForPositives.Length = 1) if isNumber then if isPositive then @@ -890,12 +891,12 @@ module internal PrintfImpl = str.PadLeft(w, ' ') /// handler right justification when pad char = ' ' - let inline rightJustifyWithSpaceAsPadChar (str : string) isNumber isPositive w (prefixForPositives : string) = + let inline rightJustifyWithSpaceAsPadChar (str: string) isNumber isPositive w (prefixForPositives: string) = System.Diagnostics.Debug.Assert(prefixForPositives.Length = 0 || prefixForPositives.Length = 1) (if isNumber && isPositive then prefixForPositives + str else str).PadLeft(w, ' ') /// handles left justification with formatting with 'G'\'g' - either for decimals or with 'g'\'G' is explicitly set - let inline leftJustifyWithGFormat (str : string) isNumber isInteger isPositive w (prefixForPositives : string) padChar = + let inline leftJustifyWithGFormat (str: string) isNumber isInteger isPositive w (prefixForPositives: string) padChar = if isNumber then let str = if isPositive then prefixForPositives + str else str // NOTE: difference - for 'g' format we use isInt check to detect situations when '5.0' is printed as '5' @@ -907,7 +908,7 @@ module internal PrintfImpl = else str.PadRight(w, ' ') // pad NaNs with ' ' - let inline leftJustifyWithNonGFormat (str : string) isNumber isPositive w (prefixForPositives : string) padChar = + let inline leftJustifyWithNonGFormat (str: string) isNumber isPositive w (prefixForPositives: string) padChar = if isNumber then let str = if isPositive then prefixForPositives + str else str str.PadRight(w, padChar) @@ -915,103 +916,103 @@ module internal PrintfImpl = str.PadRight(w, ' ') // pad NaNs with ' ' /// processes given string based depending on values isNumber\isPositive - let inline noJustificationCore (str : string) isNumber isPositive prefixForPositives = + let inline noJustificationCore (str: string) isNumber isPositive prefixForPositives = if isNumber && isPositive then prefixForPositives + str else str - /// noJustification handler for f : 'T -> string - basic integer types - let inline noJustification f (prefix : string) isUnsigned = + /// noJustification handler for f: 'T -> string - basic integer types + let inline noJustification f (prefix: string) isUnsigned = if isUnsigned then fun v -> noJustificationCore (f v) true true prefix else fun v -> noJustificationCore (f v) true (isPositive v) prefix - /// noJustification handler for f : string -> 'T -> string - floating point types - let inline noJustificationWithFormat f (prefix : string) = - fun (fmt : string) v -> noJustificationCore (f fmt v) true (isPositive v) prefix + /// noJustification handler for f: string -> 'T -> string - floating point types + let inline noJustificationWithFormat f (prefix: string) = + fun (fmt: string) v -> noJustificationCore (f fmt v) true (isPositive v) prefix - /// leftJustify handler for f : 'T -> string - basic integer types - let inline leftJustify isGFormat f (prefix : string) padChar isUnsigned = + /// leftJustify handler for f: 'T -> string - basic integer types + let inline leftJustify isGFormat f (prefix: string) padChar isUnsigned = if isUnsigned then if isGFormat then - fun (w : int) v -> + fun (w: int) v -> leftJustifyWithGFormat (f v) true (isInteger v) true w prefix padChar else - fun (w : int) v -> + fun (w: int) v -> leftJustifyWithNonGFormat (f v) true true w prefix padChar else if isGFormat then - fun (w : int) v -> + fun (w: int) v -> leftJustifyWithGFormat (f v) true (isInteger v) (isPositive v) w prefix padChar else - fun (w : int) v -> + fun (w: int) v -> leftJustifyWithNonGFormat (f v) true (isPositive v) w prefix padChar - /// leftJustify handler for f : string -> 'T -> string - floating point types - let inline leftJustifyWithFormat isGFormat f (prefix : string) padChar = + /// leftJustify handler for f: string -> 'T -> string - floating point types + let inline leftJustifyWithFormat isGFormat f (prefix: string) padChar = if isGFormat then - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> leftJustifyWithGFormat (f fmt v) true (isInteger v) (isPositive v) w prefix padChar else - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> leftJustifyWithNonGFormat (f fmt v) true (isPositive v) w prefix padChar - /// rightJustify handler for f : 'T -> string - basic integer types - let inline rightJustify f (prefixForPositives : string) padChar isUnsigned = + /// rightJustify handler for f: 'T -> string - basic integer types + let inline rightJustify f (prefixForPositives: string) padChar isUnsigned = if isUnsigned then if padChar = '0' then - fun (w : int) v -> + fun (w: int) v -> rightJustifyWithZeroAsPadChar (f v) true true w prefixForPositives else System.Diagnostics.Debug.Assert((padChar = ' ')) - fun (w : int) v -> + fun (w: int) v -> rightJustifyWithSpaceAsPadChar (f v) true true w prefixForPositives else if padChar = '0' then - fun (w : int) v -> + fun (w: int) v -> rightJustifyWithZeroAsPadChar (f v) true (isPositive v) w prefixForPositives else System.Diagnostics.Debug.Assert((padChar = ' ')) - fun (w : int) v -> + fun (w: int) v -> rightJustifyWithSpaceAsPadChar (f v) true (isPositive v) w prefixForPositives - /// rightJustify handler for f : string -> 'T -> string - floating point types - let inline rightJustifyWithFormat f (prefixForPositives : string) padChar = + /// rightJustify handler for f: string -> 'T -> string - floating point types + let inline rightJustifyWithFormat f (prefixForPositives: string) padChar = if padChar = '0' then - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> rightJustifyWithZeroAsPadChar (f fmt v) true (isPositive v) w prefixForPositives else System.Diagnostics.Debug.Assert((padChar = ' ')) - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> rightJustifyWithSpaceAsPadChar (f fmt v) true (isPositive v) w prefixForPositives module Float = - let inline noJustification f (prefixForPositives : string) = - fun (fmt : string) v -> + let inline noJustification f (prefixForPositives: string) = + fun (fmt: string) v -> GenericNumber.noJustificationCore (f fmt v) (isNumber v) (isPositive v) prefixForPositives - let inline leftJustify isGFormat f (prefix : string) padChar = + let inline leftJustify isGFormat f (prefix: string) padChar = if isGFormat then - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> GenericNumber.leftJustifyWithGFormat (f fmt v) (isNumber v) (isInteger v) (isPositive v) w prefix padChar else - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> GenericNumber.leftJustifyWithNonGFormat (f fmt v) (isNumber v) (isPositive v) w prefix padChar - let inline rightJustify f (prefixForPositives : string) padChar = + let inline rightJustify f (prefixForPositives: string) padChar = if padChar = '0' then - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> GenericNumber.rightJustifyWithZeroAsPadChar (f fmt v) (isNumber v) (isPositive v) w prefixForPositives else System.Diagnostics.Debug.Assert((padChar = ' ')) - fun (fmt : string) (w : int) v -> + fun (fmt: string) (w: int) v -> GenericNumber.rightJustifyWithSpaceAsPadChar (f fmt v) (isNumber v) (isPositive v) w prefixForPositives - let isDecimalFormatSpecifier (spec : FormatSpecifier) = + let isDecimalFormatSpecifier (spec: FormatSpecifier) = spec.TypeChar = 'M' - let getPadAndPrefix allowZeroPadding (spec : FormatSpecifier) = + let getPadAndPrefix allowZeroPadding (spec: FormatSpecifier) = let padChar = if allowZeroPadding && isPadWithZeros spec.Flags then '0' else ' '; let prefix = if isPlusForPositives spec.Flags then "+" @@ -1019,57 +1020,57 @@ module internal PrintfImpl = else "" padChar, prefix - let isGFormat(spec : FormatSpecifier) = + let isGFormat(spec: FormatSpecifier) = isDecimalFormatSpecifier spec || System.Char.ToLower(spec.TypeChar) = 'g' - let inline basicWithPadding (spec : FormatSpecifier) f = + let inline basicWithPadding (spec: FormatSpecifier) f = let padChar, _ = getPadAndPrefix false spec Padding.withPadding spec f (Basic.leftJustify f padChar) (Basic.rightJustify f padChar) - let inline numWithPadding (spec : FormatSpecifier) isUnsigned f = + let inline numWithPadding (spec: FormatSpecifier) isUnsigned f = let allowZeroPadding = not (isLeftJustify spec.Flags) || isDecimalFormatSpecifier spec let padChar, prefix = getPadAndPrefix allowZeroPadding spec let isGFormat = isGFormat spec Padding.withPadding spec (GenericNumber.noJustification f prefix isUnsigned) (GenericNumber.leftJustify isGFormat f prefix padChar isUnsigned) (GenericNumber.rightJustify f prefix padChar isUnsigned) - let inline decimalWithPadding (spec : FormatSpecifier) getFormat defaultFormat f = + let inline decimalWithPadding (spec: FormatSpecifier) getFormat defaultFormat f = let padChar, prefix = getPadAndPrefix true spec let isGFormat = isGFormat spec Padding.withPaddingFormatted spec getFormat defaultFormat (GenericNumber.noJustificationWithFormat f prefix) (GenericNumber.leftJustifyWithFormat isGFormat f prefix padChar) (GenericNumber.rightJustifyWithFormat f prefix padChar) - let inline floatWithPadding (spec : FormatSpecifier) getFormat defaultFormat f = + let inline floatWithPadding (spec: FormatSpecifier) getFormat defaultFormat f = let padChar, prefix = getPadAndPrefix true spec let isGFormat = isGFormat spec Padding.withPaddingFormatted spec getFormat defaultFormat (Float.noJustification f prefix) (Float.leftJustify isGFormat f prefix padChar) (Float.rightJustify f prefix padChar) let inline identity v = v - let inline toString v = (^T : (member ToString : IFormatProvider -> string)(v, invariantCulture)) - let inline toFormattedString fmt = fun (v : ^T) -> (^T : (member ToString : string * IFormatProvider -> string)(v, fmt, invariantCulture)) + let inline toString v = (^T : (member ToString: IFormatProvider -> string)(v, invariantCulture)) + let inline toFormattedString fmt = fun (v: ^T) -> (^T: (member ToString: string * IFormatProvider -> string)(v, fmt, invariantCulture)) let inline numberToString c spec alt unsignedConv = if c = 'd' || c = 'i' then - numWithPadding spec false (alt >> toString : ^T -> string) + numWithPadding spec false (alt >> toString: ^T -> string) elif c = 'u' then - numWithPadding spec true (alt >> unsignedConv >> toString : ^T -> string) + numWithPadding spec true (alt >> unsignedConv >> toString: ^T -> string) elif c = 'x' then - numWithPadding spec true (alt >> toFormattedString "x" : ^T -> string) + numWithPadding spec true (alt >> toFormattedString "x": ^T -> string) elif c = 'X' then - numWithPadding spec true (alt >> toFormattedString "X" : ^T -> string ) + numWithPadding spec true (alt >> toFormattedString "X": ^T -> string ) elif c = 'o' then - numWithPadding spec true (fun (v : ^T) -> Convert.ToString(int64(unsignedConv (alt v)), 8)) + numWithPadding spec true (fun (v: ^T) -> Convert.ToString(int64(unsignedConv (alt v)), 8)) else raise (ArgumentException()) type ObjectPrinter = - static member ObjectToString<'T>(spec : FormatSpecifier) = - basicWithPadding spec (fun (v : 'T) -> match box v with null -> "" | x -> x.ToString()) + static member ObjectToString<'T>(spec: FormatSpecifier) = + basicWithPadding spec (fun (v: 'T) -> match box v with null -> "" | x -> x.ToString()) - static member GenericToStringCore(v : 'T, opts : Microsoft.FSharp.Text.StructuredPrintfImpl.FormatOptions, bindingFlags) = + static member GenericToStringCore(v: 'T, opts: Microsoft.FSharp.Text.StructuredPrintfImpl.FormatOptions, bindingFlags) = // printfn %0A is considered to mean 'print width zero' match box v with | null -> "" | _ -> Microsoft.FSharp.Text.StructuredPrintfImpl.Display.anyToStringForPrintf opts bindingFlags (v, v.GetType()) - static member GenericToString<'T>(spec : FormatSpecifier) = + static member GenericToString<'T>(spec: FormatSpecifier) = let bindingFlags = #if FX_RESHAPED_REFLECTION isPlusForPositives spec.Flags // true - show non-public @@ -1089,65 +1090,65 @@ module internal PrintfImpl = else o match spec.IsStarWidth, spec.IsStarPrecision with | true, true -> - box (fun (v : 'T) (width : int) (prec : int) -> + box (fun (v: 'T) (width: int) (prec: int) -> let opts = { opts with PrintSize = prec } let opts = if not useZeroWidth then { opts with PrintWidth = width} else opts ObjectPrinter.GenericToStringCore(v, opts, bindingFlags) ) | true, false -> - box (fun (v : 'T) (width : int) -> + box (fun (v: 'T) (width: int) -> let opts = if not useZeroWidth then { opts with PrintWidth = width} else opts ObjectPrinter.GenericToStringCore(v, opts, bindingFlags) ) | false, true -> - box (fun (v : 'T) (prec : int) -> + box (fun (v: 'T) (prec: int) -> let opts = { opts with PrintSize = prec } ObjectPrinter.GenericToStringCore(v, opts, bindingFlags) ) | false, false -> - box (fun (v : 'T) -> + box (fun (v: 'T) -> ObjectPrinter.GenericToStringCore(v, opts, bindingFlags) ) - let basicNumberToString (ty : Type) (spec : FormatSpecifier) = + let basicNumberToString (ty: Type) (spec: FormatSpecifier) = System.Diagnostics.Debug.Assert(not spec.IsPrecisionSpecified, "not spec.IsPrecisionSpecified") let ch = spec.TypeChar match Type.GetTypeCode(ty) with - | TypeCode.Int32 -> numberToString ch spec identity (uint32 : int -> uint32) - | TypeCode.Int64 -> numberToString ch spec identity (uint64 : int64 -> uint64) - | TypeCode.Byte -> numberToString ch spec identity (byte : byte -> byte) - | TypeCode.SByte -> numberToString ch spec identity (byte : sbyte -> byte) - | TypeCode.Int16 -> numberToString ch spec identity (uint16 : int16 -> uint16) - | TypeCode.UInt16 -> numberToString ch spec identity (uint16 : uint16 -> uint16) - | TypeCode.UInt32 -> numberToString ch spec identity (uint32 : uint32 -> uint32) - | TypeCode.UInt64 -> numberToString ch spec identity (uint64 : uint64 -> uint64) + | TypeCode.Int32 -> numberToString ch spec identity (uint32: int -> uint32) + | TypeCode.Int64 -> numberToString ch spec identity (uint64: int64 -> uint64) + | TypeCode.Byte -> numberToString ch spec identity (byte: byte -> byte) + | TypeCode.SByte -> numberToString ch spec identity (byte: sbyte -> byte) + | TypeCode.Int16 -> numberToString ch spec identity (uint16: int16 -> uint16) + | TypeCode.UInt16 -> numberToString ch spec identity (uint16: uint16 -> uint16) + | TypeCode.UInt32 -> numberToString ch spec identity (uint32: uint32 -> uint32) + | TypeCode.UInt64 -> numberToString ch spec identity (uint64: uint64 -> uint64) | _ -> if ty === typeof then if IntPtr.Size = 4 then - numberToString ch spec (fun (v : IntPtr) -> v.ToInt32()) uint32 + numberToString ch spec (fun (v: IntPtr) -> v.ToInt32()) uint32 else - numberToString ch spec (fun (v : IntPtr) -> v.ToInt64()) uint64 + numberToString ch spec (fun (v: IntPtr) -> v.ToInt64()) uint64 elif ty === typeof then if IntPtr.Size = 4 then - numberToString ch spec (fun (v : UIntPtr) -> v.ToUInt32()) uint32 + numberToString ch spec (fun (v: UIntPtr) -> v.ToUInt32()) uint32 else - numberToString ch spec (fun (v : UIntPtr) -> v.ToUInt64()) uint64 + numberToString ch spec (fun (v: UIntPtr) -> v.ToUInt64()) uint64 else raise (ArgumentException(ty.Name + " not a basic integer type")) let basicFloatToString ty spec = let defaultFormat = getFormatForFloat spec.TypeChar DefaultPrecision match Type.GetTypeCode(ty) with - | TypeCode.Single -> floatWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v : float32) -> toFormattedString fmt v) - | TypeCode.Double -> floatWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v : float) -> toFormattedString fmt v) - | TypeCode.Decimal -> decimalWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v : decimal) -> toFormattedString fmt v) + | TypeCode.Single -> floatWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v: float32) -> toFormattedString fmt v) + | TypeCode.Double -> floatWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v: float) -> toFormattedString fmt v) + | TypeCode.Decimal -> decimalWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v: decimal) -> toFormattedString fmt v) | _ -> raise (ArgumentException(ty.Name + " not a basic floating point type")) let private NonPublicStatics = BindingFlags.NonPublic ||| BindingFlags.Static - let private getValueConverter (ty : Type) (spec : FormatSpecifier) : obj = + let private getValueConverter (ty: Type) (spec: FormatSpecifier) : obj = match spec.TypeChar with | 'b' -> System.Diagnostics.Debug.Assert(ty === typeof, "ty === typeof") @@ -1157,10 +1158,10 @@ module internal PrintfImpl = basicWithPadding spec stringToSafeString | 'c' -> System.Diagnostics.Debug.Assert(ty === typeof, "ty === typeof") - basicWithPadding spec (fun (c : char) -> c.ToString()) + basicWithPadding spec (fun (c: char) -> c.ToString()) | 'M' -> System.Diagnostics.Debug.Assert(ty === typeof, "ty === typeof") - decimalWithPadding spec (fun _ -> "G") "G" (fun fmt (v : decimal) -> toFormattedString fmt v) // %M ignores precision + decimalWithPadding spec (fun _ -> "G") "G" (fun fmt (v: decimal) -> toFormattedString fmt v) // %M ignores precision | 'd' | 'i' | 'x' | 'X' | 'u' | 'o'-> basicNumberToString ty spec | 'e' | 'E' @@ -1178,10 +1179,10 @@ module internal PrintfImpl = | _ -> raise (ArgumentException(SR.GetString(SR.printfBadFormatSpecifier))) - let extractCurriedArguments (ty : Type) n = + let extractCurriedArguments (ty: Type) n = System.Diagnostics.Debug.Assert(n = 1 || n = 2 || n = 3, "n = 1 || n = 2 || n = 3") let buf = Array.zeroCreate (n + 1) - let rec go (ty : Type) i = + let rec go (ty: Type) i = if i < n then match ty.GetGenericArguments() with | [| argTy; retTy|] -> @@ -1198,7 +1199,7 @@ module internal PrintfImpl = let args = Stack(10) let types = Stack(5) - let stackToArray size start count (s : Stack<_>) = + let stackToArray size start count (s: Stack<_>) = let arr = Array.zeroCreate size for i = 0 to count - 1 do arr.[start + i] <- s.Pop() @@ -1224,7 +1225,7 @@ module internal PrintfImpl = member __.PopValueUnsafe() = args.Pop() - member this.PushContinuationWithType (cont : obj, contTy : Type) = + member this.PushContinuationWithType (cont: obj, contTy: Type) = System.Diagnostics.Debug.Assert(this.IsEmpty, "this.IsEmpty") System.Diagnostics.Debug.Assert( ( @@ -1236,10 +1237,10 @@ module internal PrintfImpl = this.PushArgumentWithType(cont, contTy) - member __.PushArgument(value : obj) = + member __.PushArgument(value: obj) = args.Push value - member __.PushArgumentWithType(value : obj, ty) = + member __.PushArgumentWithType(value: obj, ty) = args.Push value types.Push ty @@ -1259,12 +1260,12 @@ module internal PrintfImpl = let mutable count = 0 let mutable optimizedArgCount = 0 #if DEBUG - let verifyMethodInfoWasTaken (mi : System.Reflection.MemberInfo) = + let verifyMethodInfoWasTaken (mi: System.Reflection.MemberInfo) = if isNull mi then ignore (System.Diagnostics.Debugger.Launch()) #endif - let buildSpecialChained(spec : FormatSpecifier, argTys : Type[], prefix : string, tail : obj, retTy) = + let buildSpecialChained(spec: FormatSpecifier, argTys: Type[], prefix: string, tail: obj, retTy) = if spec.TypeChar = 'a' then let mi = typeof>.GetMethod("LittleAChained", NonPublicStatics) #if DEBUG @@ -1304,7 +1305,7 @@ module internal PrintfImpl = let mi = mi.MakeGenericMethod argTypes mi.Invoke(null, args) - let buildSpecialFinal(spec : FormatSpecifier, argTys : Type[], prefix : string, suffix : string) = + let buildSpecialFinal(spec: FormatSpecifier, argTys: Type[], prefix: string, suffix: string) = if spec.TypeChar = 'a' then let mi = typeof>.GetMethod("LittleAFinal", NonPublicStatics) #if DEBUG @@ -1343,7 +1344,7 @@ module internal PrintfImpl = mi.Invoke(null, args) - let buildPlainFinal(args : obj[], argTypes : Type[]) = + let buildPlainFinal(args: obj[], argTypes: Type[]) = let argsCount = args.Length let methodName,args = if argsCount > 0 && args.[0].ToString() = "" then @@ -1368,7 +1369,7 @@ module internal PrintfImpl = let mi = mi.MakeGenericMethod(argTypes) mi.Invoke(null, args) - let buildPlainChained(args : obj[], argTypes : Type[]) = + let buildPlainChained(args: obj[], argTypes: Type[]) = let argsCount = args.Length let methodName,args = if argsCount > 0 && args.[0].ToString() = "" then @@ -1407,7 +1408,7 @@ module internal PrintfImpl = else buildPlainFinal(plainArgs, plainTypes) - let rec parseFromFormatSpecifier (prefix : string) (s : string) (funcTy : Type) i : int = + let rec parseFromFormatSpecifier (prefix: string) (s: string) (funcTy: Type) i: int = if i >= s.Length then 0 else @@ -1499,11 +1500,11 @@ module internal PrintfImpl = else numberOfArgs + 1 - let parseFormatString (s : string) (funcTy : System.Type) : obj = + let parseFormatString (s: string) (funcTy: System.Type) : obj = optimizedArgCount <- 0 let prefixPos, prefix = FormatString.findNextFormatSpecifier s 0 if prefixPos = s.Length then - box (fun (env : unit -> PrintfEnv<'S, 'Re, 'Res>) -> + box (fun (env: unit -> PrintfEnv<'S, 'Re, 'Res>) -> let env = env() env.Write prefix env.Finish() @@ -1516,7 +1517,7 @@ module internal PrintfImpl = else buildPlain n prefix - member __.Build<'T>(s : string) : PrintfFactory<'S, 'Re, 'Res, 'T> * int = + member __.Build<'T>(s: string) : PrintfFactory<'S, 'Re, 'Res, 'T> * int = parseFormatString s typeof<'T> :?> _, (2 * count + 1) - optimizedArgCount // second component is used in SprintfEnv as value for internal buffer /// Type of element that is stored in cache @@ -1531,13 +1532,13 @@ module internal PrintfImpl = static let generate(fmt) = PrintfBuilder<'State, 'Residue, 'Result>().Build<'T>(fmt) static let mutable map = System.Collections.Concurrent.ConcurrentDictionary>() static let getOrAddFunc = Func<_, _>(generate) - static let get(key : string) = map.GetOrAdd(key, getOrAddFunc) + static let get(key: string) = map.GetOrAdd(key, getOrAddFunc) [] [] - static val mutable private last : string * CachedItem<'T, 'State, 'Residue, 'Result> + static val mutable private last: string * CachedItem<'T, 'State, 'Residue, 'Result> - static member Get(key : Format<'T, 'State, 'Residue, 'Result>) = + static member Get(key: Format<'T, 'State, 'Residue, 'Result>) = if not (Cache<'T, 'State, 'Residue, 'Result>.last === null) && key.Value.Equals (fst Cache<'T, 'State, 'Residue, 'Result>.last) then snd Cache<'T, 'State, 'Residue, 'Result>.last @@ -1549,11 +1550,11 @@ module internal PrintfImpl = type StringPrintfEnv<'Result>(k, n) = inherit PrintfEnv(()) - let buf : string[] = Array.zeroCreate n + let buf: string[] = Array.zeroCreate n let mutable ptr = 0 override __.Finish() : 'Result = k (String.Concat(buf)) - override __.Write(s : string) = + override __.Write(s: string) = buf.[ptr] <- s ptr <- ptr + 1 override __.WriteT(s) = @@ -1566,19 +1567,19 @@ module internal PrintfImpl = let mutable c = null override __.Finish() : 'Result = k c - override __.Write(s : string) = if isNull c then c <- s else c <- c + s + override __.Write(s: string) = if isNull c then c <- s else c <- c + s override __.WriteT(s) = if isNull c then c <- s else c <- c + s type StringBuilderPrintfEnv<'Result>(k, buf) = inherit PrintfEnv(buf) override __.Finish() : 'Result = k () - override __.Write(s : string) = ignore(buf.Append(s)) + override __.Write(s: string) = ignore(buf.Append(s)) override __.WriteT(()) = () - type TextWriterPrintfEnv<'Result>(k, tw : IO.TextWriter) = + type TextWriterPrintfEnv<'Result>(k, tw: IO.TextWriter) = inherit PrintfEnv(tw) override __.Finish() : 'Result = k() - override __.Write(s : string) = tw.Write s + override __.Write(s: string) = tw.Write s override __.WriteT(()) = () let inline doPrintf fmt f = @@ -1602,7 +1603,7 @@ module Printf = type TextWriterFormat<'T> = TextWriterFormat<'T,unit> [] - let ksprintf continuation (format : StringFormat<'T, 'Result>) : 'T = + let ksprintf continuation (format: StringFormat<'T, 'Result>) : 'T = doPrintf format (fun n -> if n <= 2 then SmallStringPrintfEnv(continuation) :> PrintfEnv<_, _, _> @@ -1611,7 +1612,7 @@ module Printf = ) [] - let sprintf (format : StringFormat<'T>) = + let sprintf (format: StringFormat<'T>) = doPrintf format (fun n -> if n <= 2 then SmallStringPrintfEnv(id) :> PrintfEnv<_, _, _> diff --git a/src/fsharp/FSharp.Core/quotations.fs b/src/fsharp/FSharp.Core/quotations.fs index 7af4a9f7956..58d0ef293d9 100644 --- a/src/fsharp/FSharp.Core/quotations.fs +++ b/src/fsharp/FSharp.Core/quotations.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. namespace Microsoft.FSharp.Quotations @@ -18,7 +18,7 @@ open Microsoft.FSharp.Text.StructuredPrintfImpl open Microsoft.FSharp.Text.StructuredPrintfImpl.LayoutOps open Microsoft.FSharp.Text.StructuredPrintfImpl.TaggedTextOps -#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation +#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation #if FX_RESHAPED_REFLECTION open PrimReflectionAdapters @@ -29,29 +29,29 @@ open ReflectionAdapters // RAW quotations - basic data types //-------------------------------------------------------------------------- -module Helpers = +module Helpers = let qOneOrMoreRLinear q inp = - let rec queryAcc rvs e = - match q e with - | Some(v,body) -> queryAcc (v::rvs) body - | None -> - match rvs with + let rec queryAcc rvs e = + match q e with + | Some(v, body) -> queryAcc (v::rvs) body + | None -> + match rvs with | [] -> None - | _ -> Some(List.rev rvs,e) - queryAcc [] inp + | _ -> 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) - | None -> - match rvs with + let rec queryAcc e rvs = + match q e with + | Some(body, v) -> queryAcc body (v::rvs) + | None -> + match rvs with | [] -> None - | _ -> Some(e,rvs) + | _ -> 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 @@ -62,7 +62,7 @@ module Helpers = let publicOrPrivateBindingFlags = BindingFlags.Public ||| BindingFlags.NonPublic #endif - let isDelegateType (typ:Type) = + let isDelegateType (typ:Type) = if typ.IsSubclassOf(typeof) then match typ.GetMethod("Invoke", instanceBindingFlags) with | null -> false @@ -70,16 +70,16 @@ module Helpers = else false - let getDelegateInvoke ty = + let getDelegateInvoke ty = 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 inline checkNonNull argName (v: 'T) = + match box v with + | null -> nullArg argName | _ -> () - + let getTypesFromParamInfos (infos : ParameterInfo[]) = infos |> Array.map (fun pi -> pi.ParameterType) open Helpers @@ -87,7 +87,7 @@ open Helpers [] [] -[] +[] type Var(name: string, typ:Type, ?isMutable: bool) = inherit obj() @@ -95,70 +95,70 @@ 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 - + member v.Name = name member v.IsMutable = isMutable member v.Type = typ member v.Stamp = stamp - - static member Global(name,typ: Type) = + + static member Global(name, typ: Type) = checkNonNull "name" name checkNonNull "typ" typ - lock globals (fun () -> + lock globals (fun () -> let mutable res = Unchecked.defaultof - let ok = globals.TryGetValue((name,typ),&res) + let ok = globals.TryGetValue((name, typ), &res) if ok then res else - let res = new Var(name,typ) - globals.[(name,typ)] <- res + let res = new Var(name, typ) + globals.[(name, typ)] <- res res) override v.ToString() = name override v.GetHashCode() = base.GetHashCode() - override v.Equals(obj:obj) = - match obj with - | :? Var as v2 -> System.Object.ReferenceEquals(v,v2) + 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) = - 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 + interface System.IComparable with + 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 #if !FX_NO_REFLECTION_METADATA_TOKENS // not available on Compact Framework - 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.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 #endif - let c = compare v.Type.Assembly.FullName v2.Type.Assembly.FullName - 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 +/// Represents specifications of a subset of F# expressions [] type Tree = | CombTerm of ExprConstInfo * Expr list | VarTerm of Var - | LambdaTerm of Var * Expr + | LambdaTerm of Var * Expr | HoleTerm of Type * int -and +and [] - ExprConstInfo = + ExprConstInfo = | AppOp - | IfThenElseOp - | LetRecOp - | LetRecCombOp - | LetOp + | IfThenElseOp + | LetRecOp + | LetRecCombOp + | LetOp | NewRecordOp of Type | NewUnionCaseOp of UnionCaseInfo | UnionCaseTestOp of UnionCaseInfo @@ -172,56 +172,56 @@ and | StaticFieldGetOp of FieldInfo | InstanceFieldSetOp of FieldInfo | StaticFieldSetOp of FieldInfo - | NewObjectOp of ConstructorInfo - | InstanceMethodCallOp of MethodInfo - | StaticMethodCallOp of MethodInfo + | NewObjectOp of ConstructorInfo + | InstanceMethodCallOp of MethodInfo + | StaticMethodCallOp of MethodInfo | CoerceOp of Type | NewArrayOp of Type | NewDelegateOp of Type | QuoteOp of bool - | SequentialOp - | AddressOfOp + | SequentialOp + | AddressOfOp | VarSetOp - | AddressSetOp + | AddressSetOp | TypeTestOp of Type - | TryWithOp - | TryFinallyOp - | ForIntegerRangeLoopOp - | WhileLoopOp + | TryWithOp + | TryFinallyOp + | ForIntegerRangeLoopOp + | WhileLoopOp // Arbitrary spliced values - not serialized | ValueOp of obj * Type * string option - | WithValueOp of obj * Type + | WithValueOp of obj * Type | DefaultValueOp of Type - + and [] - Expr(term:Tree,attribs:Expr list) = + Expr(term:Tree, attribs:Expr list) = member x.Tree = term - member x.CustomAttributes = attribs + member x.CustomAttributes = attribs - override x.Equals(obj) = - match obj with - | :? Expr as y -> - let rec eq t1 t2 = - match t1, t2 with + override x.Equals(obj) = + match obj with + | :? Expr as y -> + 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(c1, es1), CombTerm(c2,es2) -> c1 = c2 && es1.Length = es2.Length && (es1 = es2) + | CombTerm(ValueOp(v1, ty1, _), []), CombTerm(ValueOp(v2, ty2, _), []) -> (v1 = v2) && (ty1 = ty2) + | 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.GetHashCode() = + x.Tree.GetHashCode() override x.ToString() = x.ToString(false) - member x.ToString(full) = + member x.ToString(full) = Microsoft.FSharp.Text.StructuredPrintfImpl.Display.layout_to_string Microsoft.FSharp.Text.StructuredPrintfImpl.FormatOptions.Default (x.GetLayout(full)) - - member x.GetLayout(long) = + + 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) @@ -231,137 +231,137 @@ and [] 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 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 (|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 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) + 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) | _ -> 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(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]) -> + 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(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]) + 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] else - match e with - | NLambdas nargs (vs,e) -> combL "NewDelegate" ([typeL ty] @ (vs |> List.map varL) @ [expr e]) + match e with + | NLambdas nargs (vs, e) -> combL "NewDelegate" ([typeL ty] @ (vs |> List.map varL) @ [expr e]) | _ -> combL "NewDelegate" [typeL ty; expr e] - //| CombTerm(_,args) -> combL "??" (exprs args) - | VarTerm(v) -> wordL (tagLocal v.Name) - | LambdaTerm(v,b) -> combL "Lambda" [varL v; expr b] - | HoleTerm _ -> wordL (tagLocal "_") - | CombTerm(QuoteOp _,args) -> combL "Quote" (exprs args) + //| CombTerm(_, args) -> combL "??" (exprs args) + | VarTerm(v) -> wordL (tagLocal v.Name) + | LambdaTerm(v, b) -> combL "Lambda" [varL v; expr b] + | HoleTerm _ -> wordL (tagLocal "_") + | CombTerm(QuoteOp _, args) -> combL "Quote" (exprs args) | _ -> failwithf "Unexpected term in layout %A" x.Tree - + and [] - Expr<'T>(term:Tree,attribs) = - inherit Expr(term,attribs) + Expr<'T>(term:Tree, attribs) = + inherit Expr(term, attribs) member x.Raw = (x :> Expr) [] -module Patterns = +module Patterns = /// Internal type representing a deserialized object that is yet to be instantiated. Representation is /// 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"; + + member b.ReadByte() = + 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"; + 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] - pos <- pos + n; - res + pos <- pos + n + res - member b.ReadUtf8BytesAsString n = - let res = System.Text.Encoding.UTF8.GetString(bytes,pos,n) - pos <- pos + n; + member b.ReadUtf8BytesAsString n = + let res = System.Text.Encoding.UTF8.GetString(bytes, pos, n) + pos <- pos + n res - let E t = new Expr< >(t,[]) - let EA (t,attribs) = new Expr< >(t,attribs) + let E t = new Expr< >(t, []) + let EA (t, attribs) = new Expr< >(t, attribs) let ES ts = List.map E ts let (|E|) (e: Expr) = e.Tree let (|ES|) (es: list) = es |> List.map (fun e -> e.Tree) - let (|FrontAndBack|_|) es = + 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 mkFunTy a b = + let mkFunTy a b = let (a, b) = removeVoid a, removeVoid b funTyC.MakeGenericType([| a;b |]) - let mkArrayTy (t:Type) = t.MakeArrayType(); + let mkArrayTy (t:Type) = t.MakeArrayType() let mkExprTy (t:Type) = exprTyC.MakeGenericType([| t |]) let rawExprTy = typeof @@ -370,560 +370,560 @@ module Patterns = // 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 (|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) + let (|ValueWithName|_|) input = + match input with + | 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) + let (|WithValue|_|) input = + match input with + | E(CombTerm(WithValueOp (v, ty), [e])) -> Some(v, ty, e) | _ -> None [] - let (|AddressOf|_|) input = - match input with - | Comb1(AddressOfOp,e) -> Some(e) + let (|AddressOf|_|) input = + match input with + | Comb1(AddressOfOp, e) -> Some(e) | _ -> None [] - let (|Sequential|_|) input = - match input with - | Comb2(SequentialOp,e1,e2) -> Some(e1,e2) + let (|Sequential|_|) input = + match input with + | 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) + let (|ForIntegerRangeLoop|_|) input = + match input with + | 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) + let (|WhileLoop|_|) input = + match input with + | 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) + 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) | _ -> 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) + 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) | _ -> None [] - let (|FieldGet|_|) input = - match input with - | E(CombTerm(StaticFieldGetOp finfo,[])) -> Some(None,finfo) - | E(CombTerm(InstanceFieldGetOp finfo,[obj])) -> Some(Some(obj),finfo) + let (|FieldGet|_|) input = + match input with + | 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) + 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) | _ -> None [] - let (|NewObject|_|) input = - match input with - | E(CombTerm(NewObjectOp ty,e)) -> Some(ty,e) | _ -> None + let (|NewObject|_|) input = + match input with + | 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(InstanceMethodCallOp minfo,(obj::args))) -> Some(Some(obj),minfo,args) + let (|Call|_|) input = + match input with + | E(CombTerm(StaticMethodCallOp minfo, args)) -> Some(None, minfo, args) + | E(CombTerm(InstanceMethodCallOp minfo, (obj::args))) -> Some(Some(obj), minfo, args) | _ -> None - let (|LetRaw|_|) input = - match input with - | Comb2(LetOp,e1,e2) -> Some(e1,e2) + let (|LetRaw|_|) input = + match input with + | Comb2(LetOp, e1, e2) -> Some(e1, e2) | _ -> None - let (|LetRecRaw|_|) input = - match input with - | Comb1(LetRecOp,e1) -> Some(e1) + let (|LetRecRaw|_|) input = + match input with + | Comb1(LetRecOp, e1) -> Some(e1) | _ -> None [] - let (|Let|_|)input = - match input with - | LetRaw(e,Lambda(v,body)) -> Some(v,e,body) + let (|Let|_|)input = + match input with + | 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) + 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) | _ -> None [] - let (|NewDelegate|_|) input = - match input with - | Comb1(NewDelegateOp(ty),e) -> + let (|NewDelegate|_|) input = + match input with + | 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 0 ([],e) -> Some(ty,[],e) + if nargs = 0 then + match e with + | NLambdas 1 ([_], e) -> Some(ty, [], e) // try to strip the unit parameter if there is one + | NLambdas 0 ([], e) -> Some(ty, [], e) | _ -> None else - match e with - | NLambdas nargs (vs,e) -> Some(ty,vs,e) + match e with + | NLambdas nargs (vs, e) -> Some(ty, vs, e) | _ -> None | _ -> None [] - let (|LetRecursive|_|) input = - match input with - | LetRecRaw(IteratedLambda(vs1,E(CombTerm(LetRecCombOp,body::es)))) -> Some(List.zip vs1 es,body) + let (|LetRecursive|_|) input = + match input with + | LetRecRaw(IteratedLambda(vs1, E(CombTerm(LetRecCombOp, body::es)))) -> Some(List.zip vs1 es, body) | _ -> None - + //-------------------------------------------------------------------------- // Getting the type of Raw quotations //-------------------------------------------------------------------------- // Returns record member specified by name - let getRecordProperty(ty,fieldName) = - let mems = FSharpType.GetRecordFields(ty,publicOrPrivateBindingFlags) + 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)) - let getUnionCaseInfo(ty,unionCaseName) = - let cases = FSharpType.GetUnionCases(ty,publicOrPrivateBindingFlags) + 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)) - - let getUnionCaseInfoField(unionCase:UnionCaseInfo,index) = - let fields = unionCase.GetFields() + + let getUnionCaseInfoField(unionCase:UnionCaseInfo, index) = + let fields = unionCase.GetFields() 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 + let fty = ((typeOf f):Type) + match fty.GetGenericArguments() with | [| _; b|] -> b - | _ -> raise <| System.InvalidOperationException (SR.GetString(SR.QillFormedAppOrLet)) + | _ -> raise <| System.InvalidOperationException (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 = - let (E t) = e - match t with - | VarTerm v -> v.Type - | LambdaTerm (v,b) -> mkFunTy v.Type (typeOf b) - | 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" - | LetRecCombOp,_ -> failwith "typeOfConst: LetRecCombOp" - | NewRecordOp ty,_ -> ty - | NewUnionCaseOp unionCase,_ -> unionCase.DeclaringType - | UnionCaseTestOp _,_ -> typeof - | ValueOp (_, ty, _),_ -> ty - | WithValueOp (_, ty),_ -> ty - | TupleGetOp (ty,i),_ -> FSharpType.GetTupleElements(ty).[i] - | NewTupleOp ty,_ -> ty - | StaticPropGetOp prop,_ -> prop.PropertyType - | InstancePropGetOp prop,_ -> prop.PropertyType - | StaticPropSetOp _,_ -> typeof - | InstancePropSetOp _,_ -> typeof - | InstanceFieldGetOp fld,_ -> fld.FieldType - | StaticFieldGetOp fld,_ -> fld.FieldType - | InstanceFieldSetOp _,_ -> typeof - | StaticFieldSetOp _,_ -> typeof - | NewObjectOp ctor,_ -> ctor.DeclaringType - | InstanceMethodCallOp minfo,_ -> minfo.ReturnType |> removeVoid - | StaticMethodCallOp minfo,_ -> minfo.ReturnType |> removeVoid - | CoerceOp ty,_ -> ty - | 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 - | WhileLoopOp,_ - | VarSetOp,_ - | AddressSetOp,_ -> typeof - | AddressOfOp,[expr]-> (typeOf expr).MakeByRefType() - | (AddressOfOp | QuoteOp _ | SequentialOp | TryWithOp | TryFinallyOp | IfThenElseOp | AppOp),_ -> failwith "unreachable" + and typeOf<'T when 'T :> Expr> (e : 'T) : Type = + let (E t) = e + match t with + | VarTerm v -> v.Type + | LambdaTerm (v, b) -> mkFunTy v.Type (typeOf b) + | 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" + | LetRecCombOp, _ -> failwith "typeOfConst: LetRecCombOp" + | NewRecordOp ty, _ -> ty + | NewUnionCaseOp unionCase, _ -> unionCase.DeclaringType + | UnionCaseTestOp _, _ -> typeof + | ValueOp (_, ty, _), _ -> ty + | WithValueOp (_, ty), _ -> ty + | TupleGetOp (ty, i), _ -> FSharpType.GetTupleElements(ty).[i] + | NewTupleOp ty, _ -> ty + | StaticPropGetOp prop, _ -> prop.PropertyType + | InstancePropGetOp prop, _ -> prop.PropertyType + | StaticPropSetOp _, _ -> typeof + | InstancePropSetOp _, _ -> typeof + | InstanceFieldGetOp fld, _ -> fld.FieldType + | StaticFieldGetOp fld, _ -> fld.FieldType + | InstanceFieldSetOp _, _ -> typeof + | StaticFieldSetOp _, _ -> typeof + | NewObjectOp ctor, _ -> ctor.DeclaringType + | InstanceMethodCallOp minfo, _ -> minfo.ReturnType |> removeVoid + | StaticMethodCallOp minfo, _ -> minfo.ReturnType |> removeVoid + | CoerceOp ty, _ -> ty + | 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 + | WhileLoopOp, _ + | VarSetOp, _ + | AddressSetOp, _ -> typeof + | 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 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 //-------------------------------------------------------------------------- - + // t2 is inherited from t1 / t2 implements interface t1 or t2 == t1 - let assignableFrom (t1:Type) (t2:Type) = + let assignableFrom (t1:Type) (t2:Type) = t1.IsAssignableFrom(t2) - - let checkTypesSR (expectedType: Type) (receivedType : Type) name (threeHoleSR : string) = - if (expectedType <> receivedType) then + + let checkTypesSR (expectedType: Type) (receivedType : Type) name (threeHoleSR : string) = + if (expectedType <> receivedType) then invalidArg "receivedType" (String.Format(threeHoleSR, name, expectedType, receivedType)) - let checkTypesWeakSR (expectedType: Type) (receivedType : Type) name (threeHoleSR : string) = - if (not (assignableFrom expectedType receivedType)) then + let checkTypesWeakSR (expectedType: Type) (receivedType : Type) name (threeHoleSR : string) = + if (not (assignableFrom expectedType receivedType)) then invalidArg "receivedType" (String.Format(threeHoleSR, name, expectedType, receivedType)) - - let checkArgs (paramInfos: ParameterInfo[]) (args:list) = + + let checkArgs (paramInfos: ParameterInfo[]) (args:list) = 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))) - (paramInfos |> Array.toList) + ( 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? - let checkAssignableFrom ty1 ty2 = + let checkAssignableFrom ty1 ty2 = 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 declType = loop membInfo.DeclaringType 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 + match fty.GetGenericArguments() with | [| 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) + 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)) - - 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 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 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 mkLiftedValueOpG (v, ty: System.Type) = + let mkLiftedValueOpG (v, ty: System.Type) = 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 mkApplication v = checkAppliedLambda v; mkFE2 AppOp 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 mkApplication v = checkAppliedLambda v; mkFE2 AppOp v let mkLetRaw v = mkFE2 LetOp v - let mkLetRawWithCheck ((e1,e2) as v) = - checkAppliedLambda (e2,e1) + let mkLetRawWithCheck ((e1, e2) as v) = + checkAppliedLambda (e2, e1) 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 - mkFEN (NewTupleOp ty) args - - let mkNewTuple (args) = + mkFEN (NewTupleOp ty) args + + let mkNewTuple (args) = let ty = FSharpType.MakeTupleType(Array.map typeOf (Array.ofList args)) mkFEN (NewTupleOp ty) args - - let mkTupleGet (ty,n,x) = + + let mkTupleGet (ty, n, x) = checkTypesSR ty (typeOf x) "tupleGet" (SR.GetString(SR.QtmmExprNotMatchTuple)) - let mems = FSharpType.GetTupleElements ty + let mems = FSharpType.GetTupleElements ty if (n < 0 || mems.Length <= n) then invalidArg "n" (SR.GetString(SR.QtupleAccessOutOfRange)) - mkFE1 (TupleGetOp (ty,n)) x - + mkFE1 (TupleGetOp (ty, n)) x + // Records - let mkNewRecord (ty,args:list) = - let mems = FSharpType.GetRecordFields(ty,publicOrPrivateBindingFlags) + let mkNewRecord (ty, args: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 - - - // Discriminated unions - let mkNewUnionCase (unionCase:UnionCaseInfo,args:list) = + + + // Discriminated unions + let mkNewUnionCase (unionCase:UnionCaseInfo, args: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 + 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) = + + 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 // Conditional etc.. - let mkIfThenElse (e,t,f) = + let mkIfThenElse (e, t, f) = checkTypesSR (typeOf t) (typeOf f) "cond" (SR.GetString(SR.QtmmTrueAndFalseMustMatch)) checkTypesSR (typeof) (typeOf e) "cond" (SR.GetString(SR.QtmmCondMustBeBool)) - mkFE3 IfThenElseOp (e,t,f) - - let mkNewArray (ty,args) = + mkFE3 IfThenElseOp (e, t, f) + + let mkNewArray (ty, args) = List.iter (fun a -> checkTypesSR ty (typeOf a) "newArray" (SR.GetString(SR.QtmmInitArray))) args mkFEN (NewArrayOp ty) args - - let mkInstanceFieldGet(obj,finfo:FieldInfo) = + + let mkInstanceFieldGet(obj, finfo:FieldInfo) = if Unchecked.defaultof = finfo then raise (new ArgumentNullException()) - match finfo.IsStatic with - | false -> + match finfo.IsStatic with + | false -> checkObj finfo obj mkFE1 (InstanceFieldGetOp finfo) obj | true -> invalidArg "finfo" (SR.GetString(SR.QstaticWithReceiverObject)) - - let mkStaticFieldGet (finfo:FieldInfo) = + + let mkStaticFieldGet (finfo:FieldInfo) = if Unchecked.defaultof = finfo then raise (new ArgumentNullException()) - match finfo.IsStatic with - | true -> mkFE0 (StaticFieldGetOp finfo) + match finfo.IsStatic with + | true -> mkFE0 (StaticFieldGetOp finfo) | false -> invalidArg "finfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) - - let mkStaticFieldSet (finfo:FieldInfo,value:Expr) = + + 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 + match finfo.IsStatic with | true -> mkFE1 (StaticFieldSetOp finfo) value | false -> invalidArg "finfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) - - let mkInstanceFieldSet (obj,finfo:FieldInfo,value:Expr) = + + 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 -> + match finfo.IsStatic with + | false -> checkObj finfo obj - mkFE2 (InstanceFieldSetOp finfo) (obj,value) + mkFE2 (InstanceFieldSetOp finfo) (obj, value) | true -> invalidArg "finfo" (SR.GetString(SR.QstaticWithReceiverObject)) - - let mkCtorCall (ci:ConstructorInfo,args:list) = + + let mkCtorCall (ci:ConstructorInfo, args:list) = if Unchecked.defaultof = ci then raise (new ArgumentNullException()) checkArgs (ci.GetParameters()) args mkFEN (NewObjectOp ci) args let mkDefaultValue (ty:Type) = - mkFE0 (DefaultValueOp ty) + mkFE0 (DefaultValueOp ty) - let mkStaticPropGet (pinfo:PropertyInfo,args:list) = + let mkStaticPropGet (pinfo:PropertyInfo, args:list) = 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 + match pinfo.GetGetMethod(true).IsStatic with | true -> mkFEN (StaticPropGetOp pinfo) args | false -> invalidArg "pinfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) - let mkInstancePropGet (obj,pinfo:PropertyInfo,args:list) = + let mkInstancePropGet (obj, pinfo:PropertyInfo, args:list) = 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 -> + match pinfo.GetGetMethod(true).IsStatic with + | false -> checkObj pinfo obj mkFEN (InstancePropGetOp pinfo) (obj::args) | true -> invalidArg "pinfo" (SR.GetString(SR.QstaticWithReceiverObject)) - - let mkStaticPropSet (pinfo:PropertyInfo,args:list,value:Expr) = + + let mkStaticPropSet (pinfo:PropertyInfo, args:list, value:Expr) = 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 + match pinfo.GetSetMethod(true).IsStatic with | true -> mkFEN (StaticPropSetOp pinfo) (args@[value]) | false -> invalidArg "pinfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) - - let mkInstancePropSet (obj,pinfo:PropertyInfo,args:list,value:Expr) = + + let mkInstancePropSet (obj, pinfo:PropertyInfo, args:list, value:Expr) = 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 -> + match pinfo.GetSetMethod(true).IsStatic with + | false -> checkObj pinfo obj mkFEN (InstancePropSetOp pinfo) (obj::(args@[value])) | true -> invalidArg "pinfo" (SR.GetString(SR.QstaticWithReceiverObject)) - - let mkInstanceMethodCall (obj,minfo:MethodInfo,args:list) = + + let mkInstanceMethodCall (obj, minfo:MethodInfo, args:list) = if Unchecked.defaultof = minfo then raise (new ArgumentNullException()) checkArgs (minfo.GetParameters()) args - match minfo.IsStatic with - | false -> + match minfo.IsStatic with + | false -> checkObj minfo obj mkFEN (InstanceMethodCallOp minfo) (obj::args) | true -> invalidArg "minfo" (SR.GetString(SR.QstaticWithReceiverObject)) - - let mkStaticMethodCall (minfo:MethodInfo,args:list) = + + let mkStaticMethodCall (minfo:MethodInfo, args:list) = if Unchecked.defaultof = minfo then raise (new ArgumentNullException()) checkArgs (minfo.GetParameters()) args - match minfo.IsStatic with + match minfo.IsStatic with | true -> mkFEN (StaticMethodCallOp minfo) args | false -> invalidArg "minfo" (SR.GetString(SR.QnonStaticNoReceiverObject)) - - let mkForLoop (v:Var,lowerBound,upperBound,body) = + + 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)) - - let mkWhileLoop (guard,body) = + mkFE3 ForIntegerRangeLoopOp (lowerBound, upperBound, mkLambda(v, body)) + + let mkWhileLoop (guard, body) = checkTypesSR (typeof) (typeOf guard) "guard" (SR.GetString(SR.QtmmGuardMustBeBool)) checkTypesSR (typeof) (typeOf body) "body" (SR.GetString(SR.QtmmBodyMustBeUnit)) - mkFE2 (WhileLoopOp) (guard,body) - - let mkNewDelegate (ty,e) = + mkFE2 (WhileLoopOp) (guard, body) + + let mkNewDelegate (ty, e) = let mi = getDelegateInvoke ty let ps = mi.GetParameters() let dlfun = Array.foldBack (fun (p:ParameterInfo) rty -> mkFunTy p.ParameterType rty) 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)) - - //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,mkNewTuple args) - - let mkApplications(f: Expr,es:list>) = mkLLinear mkTupledApplication (f,es) - - let mkIteratedLambdas(vs,b) = mkRLinear mkLambda (vs,b) - + + let mkLet (v, e, b) = + checkBind (v, e) + 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, mkNewTuple args) + + let mkApplications(f: Expr, es:list>) = mkLLinear mkTupledApplication (f, es) + + let mkIteratedLambdas(vs, b) = mkRLinear mkLambda (vs, b) + let mkLetRecRaw v = mkFE1 LetRecOp v let mkLetRecCombRaw v = mkFEN LetRecCombOp v - let mkLetRec (ves:(Var*Expr) list,body) = - List.iter checkBind ves; - let vs,es = List.unzip ves - mkLetRecRaw(mkIteratedLambdas (vs,mkLetRecCombRaw (body::es))) + let mkLetRec (ves:(Var*Expr) list, body) = + List.iter checkBind ves + let vs, es = List.unzip ves + mkLetRecRaw(mkIteratedLambdas (vs, mkLetRecCombRaw (body::es))) let ReflectedDefinitionsResourceNameBase = "ReflectedDefinitions" @@ -938,103 +938,104 @@ 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 let instFormal (typarEnv: Type[]) (ty:Instantiable<'T>) = ty (fun i -> typarEnv.[i]) - let getGenericArguments(tc:Type) = - if tc.IsGenericType then tc.GetGenericArguments() else [| |] + let getGenericArguments(tc:Type) = + if tc.IsGenericType then tc.GetGenericArguments() else [| |] - let getNumGenericArguments(tc:Type) = + let getNumGenericArguments(tc:Type) = if tc.IsGenericType then tc.GetGenericArguments().Length else 0 - - let bindMethodBySearch (parentT:Type,nm,marity,argtys,rty) = - let methInfos = parentT.GetMethods(staticOrInstanceBindingFlags) |> Array.toList - // First, filter on name, if unique, then binding "done" - let tyargTs = getGenericArguments(parentT) + + let bindMethodBySearch (parentT:Type, nm, marity, argtys, rty) = + 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] -> + match methInfos with + | [methInfo] -> methInfo | _ -> - // Second, type match. + // Second, type match. let select (methInfo:MethodInfo) = - // mref implied Types - let mtyargTIs = if methInfo.IsGenericMethod then methInfo.GetGenericArguments() else [| |] + // 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 rty - - // methInfo implied Types - let haveArgTs = - let parameters = Array.toList (methInfo.GetParameters()) - parameters |> List.map (fun param -> param.ParameterType) - let haveResT = methInfo.ReturnType - // check for match + let typarEnv = (Array.append tyargTs mtyargTIs) + let argTs = argtys |> List.map (instFormal typarEnv) + let resT = instFormal typarEnv rty + + // methInfo implied Types + let haveArgTs = + let parameters = Array.toList (methInfo.GetParameters()) + parameters |> List.map (fun param -> param.ParameterType) + let haveResT = methInfo.ReturnType + // check for match if argTs.Length <> haveArgTs.Length then false (* method argument length mismatch *) else - let res = typesEqual (resT::argTs) (haveResT::haveArgTs) + let res = typesEqual (resT::argTs) (haveResT::haveArgTs) res - // return MethodInfo for (generic) type's (generic) method + // return MethodInfo for (generic) type's (generic) method match List.tryFind select methInfos with - | None -> raise <| System.InvalidOperationException (SR.GetString SR.QcannotBindToMethod) - | Some methInfo -> methInfo + | None -> raise <| System.InvalidOperationException (SR.GetString SR.QcannotBindToMethod) + | Some methInfo -> methInfo - let bindMethodHelper (parentT: Type, nm,marity,argtys,rty) = + let bindMethodHelper (parentT: Type, nm, marity, argtys, rty) = 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 rty - let methInfo = - try + 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 rty + let methInfo = + try #if FX_RESHAPED_REFLECTION - match parentT.GetMethod(nm,argTs) with -#else - match parentT.GetMethod(nm,staticOrInstanceBindingFlags,null,argTs,null) with -#endif + match parentT.GetMethod(nm, argTs) with +#else + match parentT.GetMethod(nm, staticOrInstanceBindingFlags, null, argTs, null) with +#endif | null -> None | res -> Some(res) - with :? AmbiguousMatchException -> None - match methInfo with + with :? AmbiguousMatchException -> None + match methInfo with | Some methInfo when (typeEquals resT methInfo.ReturnType) -> methInfo - | _ -> bindMethodBySearch(parentT,nm,marity,argtys,rty) - else - bindMethodBySearch(parentT,nm,marity,argtys,rty) + | _ -> bindMethodBySearch(parentT, nm, marity, argtys, rty) + else + bindMethodBySearch(parentT, nm, marity, argtys, rty) - let bindModuleProperty (ty:Type,nm) = - match ty.GetProperty(nm,staticBindingFlags) with + let bindModuleProperty (ty:Type, nm) = + match ty.GetProperty(nm, staticBindingFlags) with | null -> raise <| System.InvalidOperationException (String.Format(SR.GetString(SR.QcannotBindProperty), nm, ty.ToString())) | res -> res - + // tries to locate unique function in a given type // in case of multiple candidates returns None so bindModuleFunctionWithCallSiteArgs will be used for more precise resolution - let bindModuleFunction (ty:Type,nm) = - match ty.GetMethods(staticBindingFlags) |> Array.filter (fun mi -> mi.Name = nm) with + let bindModuleFunction (ty:Type, nm) = + match ty.GetMethods(staticBindingFlags) |> Array.filter (fun mi -> mi.Name = nm) with | [||] -> raise <| System.InvalidOperationException (String.Format(SR.GetString(SR.QcannotBindFunction), nm, ty.ToString())) | [| res |] -> Some res | _ -> None - - let bindModuleFunctionWithCallSiteArgs (ty:Type, nm, argTypes : Type list, tyArgs : Type list) = + + let bindModuleFunctionWithCallSiteArgs (ty:Type, nm, argTypes : Type list, tyArgs : Type list) = let argTypes = List.toArray argTypes let tyArgs = List.toArray tyArgs - let methInfo = - try + let methInfo = + try #if FX_RESHAPED_REFLECTION - match ty.GetMethod(nm, argTypes) with -#else - match ty.GetMethod(nm,staticOrInstanceBindingFlags,null, argTypes,null) with -#endif + match ty.GetMethod(nm, argTypes) with +#else + match ty.GetMethod(nm, staticOrInstanceBindingFlags, null, argTypes, null) with +#endif | null -> None | res -> Some(res) - with :? AmbiguousMatchException -> None - match methInfo with + 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 = + let candidates = ty.GetMethods(staticBindingFlags) |> Array.filter(fun mi -> mi.Name = nm && @@ -1075,7 +1076,7 @@ module Patterns = // - 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 parameters = mi.GetParameters() - let rec iter i acc = + let rec iter i acc = if i >= argTypes.Length then acc else let param = parameters.[i] @@ -1085,49 +1086,49 @@ module Patterns = else if param.ParameterType = argTypes.[i] then iter (i + 1) (acc + MATCH) else FAIL iter 0 0 - let solution, weight = - candidates + let solution, weight = + 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() - - let mkNamedType (tc:Type,tyargs) = - match tyargs with + | None -> fail() + + let mkNamedType (tc:Type, tyargs) = + match tyargs with | [] -> tc | _ -> tc.MakeGenericType(Array.ofList tyargs) - let inline checkNonNullResult (arg:string,err:string) y = - match box y with - | null -> raise (new ArgumentNullException(arg,err)) + 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 bindPropBySearchIfCandidateIsNull (ty : Type) propName retType argTypes candidate = + + let bindPropBySearchIfCandidateIsNull (ty : Type) propName retType argTypes candidate = match candidate with | null -> - let props = + let props = ty.GetProperties(staticOrInstanceBindingFlags) - |> Array.filter (fun pi -> + |> Array.filter (fun pi -> let paramTypes = getTypesFromParamInfos (pi.GetIndexParameters()) - pi.Name = propName && - pi.PropertyType = retType && - Array.length argTypes = paramTypes.Length && + pi.Name = propName && + pi.PropertyType = retType && + Array.length argTypes = paramTypes.Length && Array.forall2 (=) argTypes paramTypes ) match props with | [| pi |] -> pi | _ -> null | pi -> pi - - let bindCtorBySearchIfCandidateIsNull (ty : Type) argTypes candidate = + + let bindCtorBySearchIfCandidateIsNull (ty : Type) argTypes candidate = match candidate with - | null -> - let ctors = + | null -> + let ctors = ty.GetConstructors(instanceBindingFlags) |> Array.filter (fun ci -> let paramTypes = getTypesFromParamInfos (ci.GetParameters()) @@ -1138,562 +1139,595 @@ module Patterns = | [| ctor |] -> ctor | _ -> null | ctor -> ctor - - let bindProp (tc,propName,retType,argTypes,tyargs) = + + let bindProp (tc, propName, retType, argTypes, tyargs) = // We search in the instantiated type, rather than searching the generic type. - let typ = mkNamedType(tc,tyargs) + let typ = mkNamedType (tc, tyargs) let argtyps : Type list = argTypes |> inst tyargs let retType : Type = retType |> inst tyargs |> removeVoid #if FX_RESHAPED_REFLECTION - try - typ.GetProperty(propName, staticOrInstanceBindingFlags) + try + typ.GetProperty(propName, staticOrInstanceBindingFlags) with :? AmbiguousMatchException -> null // more than one property found with the specified name and matching binding constraints - return null to initiate manual search |> bindPropBySearchIfCandidateIsNull typ propName retType (Array.ofList argtyps) |> checkNonNullResult ("propName", String.Format(SR.GetString(SR.QfailedToBindProperty), propName)) // fxcop may not see "propName" as an arg -#else +#else typ.GetProperty(propName, staticOrInstanceBindingFlags, null, retType, Array.ofList argtyps, null) |> checkNonNullResult ("propName", String.Format(SR.GetString(SR.QfailedToBindProperty), propName)) // fxcop may not see "propName" as an arg #endif - let bindField (tc,fldName,tyargs) = - let typ = mkNamedType(tc,tyargs) - typ.GetField(fldName,staticOrInstanceBindingFlags) |> checkNonNullResult ("fldName", String.Format(SR.GetString(SR.QfailedToBindField), fldName)) // fxcop may not see "fldName" as an arg + let bindField (tc, fldName, tyargs) = + let typ = mkNamedType (tc, tyargs) + typ.GetField(fldName, staticOrInstanceBindingFlags) |> checkNonNullResult ("fldName", String.Format(SR.GetString(SR.QfailedToBindField), fldName)) // fxcop may not see "fldName" as an arg let bindGenericCctor (tc:Type) = - tc.GetConstructor(staticBindingFlags,null,[| |],null) - |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) + tc.GetConstructor(staticBindingFlags, null, [| |], null) + |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) - let bindGenericCtor (tc:Type,argTypes:Instantiable) = - let argtyps = instFormal (getGenericArguments tc) argTypes + let bindGenericCtor (tc:Type, argTypes:Instantiable) = + let argtyps = instFormal (getGenericArguments tc) argTypes #if FX_RESHAPED_REFLECTION let argTypes = Array.ofList argtyps - tc.GetConstructor(argTypes) + tc.GetConstructor(argTypes) |> bindCtorBySearchIfCandidateIsNull tc argTypes - |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) -#else - tc.GetConstructor(instanceBindingFlags,null,Array.ofList argtyps,null) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) + |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) +#else + tc.GetConstructor(instanceBindingFlags, null, Array.ofList argtyps, null) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) #endif - let bindCtor (tc,argTypes:Instantiable,tyargs) = - let typ = mkNamedType(tc,tyargs) + let bindCtor (tc, argTypes:Instantiable, tyargs) = + let typ = mkNamedType (tc, tyargs) let argtyps = argTypes |> inst tyargs #if FX_RESHAPED_REFLECTION let argTypes = Array.ofList argtyps - typ.GetConstructor(argTypes) + typ.GetConstructor(argTypes) |> bindCtorBySearchIfCandidateIsNull typ argTypes - |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) -#else - typ.GetConstructor(instanceBindingFlags,null,Array.ofList argtyps,null) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) + |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) +#else + typ.GetConstructor(instanceBindingFlags, null, Array.ofList argtyps, null) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) #endif let chop n xs = 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) - 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) - - let bindGenericMeth (tc:Type,argTypes : list>,retType,methName,numMethTyargs) = - bindMethodHelper(tc,methName,numMethTyargs,argTypes,retType) - - let bindMeth ((tc:Type,argTypes : list>,retType,methName,numMethTyargs),tyargs) = - let ntyargs = tc.GetGenericArguments().Length - let enclTypeArgs,methTypeArgs = chop ntyargs tyargs - let ty = mkNamedType(tc,enclTypeArgs) - let ngmeth = bindMethodHelper(ty,methName,numMethTyargs,argTypes,retType) - instMeth(ngmeth,methTypeArgs) - - let pinfoIsStatic (pinfo:PropertyInfo) = + let rec split l = + match l with + | 0, xs -> [], xs + | n, x::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) + + let bindGenericMeth (tc:Type, argTypes : list>, retType, methName, numMethTyargs) = + bindMethodHelper(tc, methName, numMethTyargs, argTypes, retType) + + let bindMeth ((tc:Type, argTypes : list>, retType, methName, numMethTyargs), tyargs) = + let ntyargs = tc.GetGenericArguments().Length + let enclTypeArgs, methTypeArgs = chop ntyargs tyargs + let ty = mkNamedType (tc, enclTypeArgs) + let ngmeth = bindMethodHelper(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 - - //-------------------------------------------------------------------------- - // Unpickling - //-------------------------------------------------------------------------- - module SimpleUnpickle = + /// Unpickling + module SimpleUnpickle = [] - type InputState = - { is: ByteStream; - istrings: string[]; - localAssembly: System.Reflection.Assembly + type InputState = + { 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_bool st = let b = u_byte_as_int st in (b = 1) let u_void (_: InputState) = () - let u_unit (_: InputState) = () - let prim_u_int32 st = - let b0 = (u_byte_as_int st) - let b1 = (u_byte_as_int st) - let b2 = (u_byte_as_int st) - let b3 = (u_byte_as_int st) + + let prim_u_int32 st = + let b0 = (u_byte_as_int st) + let b1 = (u_byte_as_int st) + let b2 = (u_byte_as_int st) + let b3 = (u_byte_as_int st) b0 ||| (b1 <<< 8) ||| (b2 <<< 16) ||| (b3 <<< 24) - let u_int32 st = - let b0 = u_byte_as_int st - if b0 <= 0x7F then b0 - elif b0 <= 0xbf then - let b0 = b0 &&& 0x7f - let b1 = (u_byte_as_int st) + let u_int32 st = + let b0 = u_byte_as_int st + if b0 <= 0x7F then b0 + elif b0 <= 0xbf then + let b0 = b0 &&& 0x7f + let b1 = (u_byte_as_int st) (b0 <<< 8) ||| b1 - else + else prim_u_int32 st - let u_bytes st = - let n = u_int32 st - st.is.ReadBytes(n) + let u_bytes st = + let len = u_int32 st + st.is.ReadBytes len + + let prim_u_string st = + let len = u_int32 st + st.is.ReadUtf8BytesAsString len + + let u_int st = u_int32 st - let prim_u_string st = - let len = (u_int32 st) - st.is.ReadUtf8BytesAsString(len) + let u_sbyte st = sbyte (u_int32 st) + + let u_byte st = byte (u_byte_as_int st) + + let u_int16 st = int16 (u_int32 st) - let u_int st = u_int32 st - let u_sbyte st = sbyte (u_int32 st) - let u_byte st = byte (u_byte_as_int st) - let u_int16 st = int16 (u_int32 st) let u_uint16 st = uint16 (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) + + 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_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_uint64 st = uint64 (u_int64 st) + + 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_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 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); + 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) tbl.[n] + let u_string st = u_uniq st.istrings st - let rec u_list_aux f acc st = - let tag = u_byte_as_int 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 + | 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 unpickleObj localAssembly referencedTypeDefs u phase2bytes = - let phase2data = - let st2 = - { is = new ByteStream(phase2bytes,0,phase2bytes.Length) + let phase2data = + let st2 = + { 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) + 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 } - let res = u st1 - res + referencedTypeDefs=referencedTypeDefs } + let res = u st1 + res open SimpleUnpickle let decodeFunTy args = - match args with + match args with | [d;r] -> funTyC.MakeGenericType([| d; r |]) | _ -> invalidArg "args" (SR.GetString(SR.QexpectedTwoTypes)) - let decodeArrayTy n (tys: Type list) = + let decodeArrayTy n (tys: Type list) = match tys with - | [ty] -> if (n = 1) then ty.MakeArrayType() else ty.MakeArrayType(n) + | [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) = - match assembly.GetType(tcName) with - | null -> + + let mkNamedTycon (tcName, assembly:Assembly) = + match assembly.GetType(tcName) with + | 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 + 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)) // "Available types are:\n%A" tcName assembly (assembly.GetTypes() |> Array.map (fun a -> a.FullName)) | ty -> ty - let decodeNamedTy tc tsR = mkNamedType(tc,tsR) + let decodeNamedTy tc tsR = mkNamedType (tc, 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 - else + elif a = "." then st.localAssembly + else #if FX_RESHAPED_REFLECTION - match System.Reflection.Assembly.Load(AssemblyName(a)) with + match System.Reflection.Assembly.Load(AssemblyName(a)) with #else - match System.Reflection.Assembly.Load(a) with + match System.Reflection.Assembly.Load(a) with #endif | null -> raise <| System.InvalidOperationException(String.Format(SR.GetString(SR.QfailedToBindAssembly), a.ToString())) | assembly -> assembly - - let u_NamedType st = - let a,b = u_tup2 u_string u_assemblyRef st + + let u_NamedType st = + let a, b = u_tup2 u_string u_assemblyRef st let mutable idx = 0 - // From FSharp.Core for F# 4.0+ (4.4.0.0+), referenced type definitions can be integer indexes into a table of type definitions provided on quotation + // From FSharp.Core for F# 4.0+ (4.4.0.0+), referenced type definitions can be integer indexes into a table of type definitions provided on quotation // deserialization, avoiding the need for System.Reflection.Assembly.Load - if System.Int32.TryParse(a, &idx) && b = "" then + if System.Int32.TryParse(a, &idx) && b = "" then st.referencedTypeDefs.[idx] - else + 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_unit st |> (fun () -> decodeFunTy) - | 2 -> u_NamedType st |> decodeNamedTy - | 3 -> u_int st |> decodeArrayTy - | _ -> failwith "u_tyconstSpec" - - let appL fs env = List.map (fun f -> f env) fs - - 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)) - | 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 (|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 u_tyconstSpec st = + let tag = u_byte_as_int st + match tag with + | 1 -> u_void st |> (fun () -> decodeFunTy) + | 2 -> u_NamedType st |> decodeNamedTy + | 3 -> u_int st |> decodeArrayTy + | _ -> failwith "u_tyconstSpec" + + let appL fs env = + List.map (fun f -> f env) fs + + 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)) + | 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 (|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" + [] - type BindingEnv = + type BindingEnv = { /// Mapping from variable index to Var object for the variable - vars : Map + 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 } + let addVar env v = + { env with vars = env.vars.Add(env.varn, v); varn=env.varn+1 } let mkTyparSubst (tyargs:Type[]) = - let n = tyargs.Length - fun idx -> + let n = tyargs.Length + fun idx -> if idx < n then tyargs.[idx] else raise <| System.InvalidOperationException (SR.GetString(SR.QtypeArgumentOutOfRange)) - let envClosed (spliceTypes:Type[]) = - { vars = Map.empty; + let envClosed (spliceTypes:Type[]) = + { 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 -> u_tup3 u_constSpec u_dtypes (u_list u_Expr) st - |> (fun (a,b,args) (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, args ))) - | 1 -> let x = u_VarRef st - (fun env -> E(VarTerm (x env))) - | 2 -> let a = u_VarDecl st - let b = u_Expr st - (fun env -> let v = a env in E(LambdaTerm(v,b (addVar env v)))) - | 3 -> let a = u_dtype st - let idx = u_int st - (fun env -> E(HoleTerm(a env.typeInst, idx))) - | 4 -> let a = u_Expr st - (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))) - | 7 -> let a = u_Expr st - (fun env -> mkQuote(a env, false)) + + 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, args))) + | 1 -> + let x = u_VarRef st + (fun env -> E(VarTerm (x env))) + | 2 -> + let a = u_VarDecl st + let b = u_Expr st + (fun env -> let v = a env in E(LambdaTerm(v, b (addVar env v)))) + | 3 -> + let a = u_dtype st + let idx = u_int st + (fun env -> E(HoleTerm(a env.typeInst, idx))) + | 4 -> + let a = u_Expr st + (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))) + | 7 -> + let a = u_Expr st + (fun env -> mkQuote(a env, false)) | _ -> failwith "u_Expr" - and u_VarDecl st = - let s,b,mut = u_tup3 u_string u_dtype u_bool st + and u_VarDecl st = + let s, b, mut = u_tup3 u_string u_dtype u_bool st (fun env -> new Var(s, b env.typeInst, mut)) - and u_VarRef st = - let i = u_int st + and u_VarRef st = + let i = u_int st (fun env -> env.vars.[i]) - and u_RecdField st = - let ty,nm = u_tup2 u_NamedType u_string st - (fun tyargs -> getRecordProperty(mkNamedType(ty,tyargs),nm)) + and u_RecdField st = + let ty, nm = u_tup2 u_NamedType u_string st + (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)) + and u_UnionCaseInfo st = + let ty, nm = u_tup2 u_NamedType u_string st + (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)) + and u_UnionCaseField st = + let case, i = u_tup2 u_UnionCaseInfo u_int st + (fun tyargs -> getUnionCaseInfoField(case tyargs, i)) - and u_ModuleDefn st = - let (ty,nm,isProp) = u_tup3 u_NamedType u_string u_bool st - if isProp then Unique(StaticPropGetOp(bindModuleProperty(ty,nm))) - else + and u_ModuleDefn st = + let (ty, nm, isProp) = u_tup3 u_NamedType u_string u_bool st + if isProp then Unique(StaticPropGetOp(bindModuleProperty(ty, nm))) + else match bindModuleFunction(ty, nm) with | Some mi -> Unique(StaticMethodCallOp(mi)) | None -> Ambiguous(fun argTypes tyargs -> StaticMethodCallOp(bindModuleFunctionWithCallSiteArgs(ty, nm, argTypes, tyargs))) - and u_MethodInfoData st = + and u_MethodInfoData st = u_tup5 u_NamedType (u_list u_dtype) u_dtype u_string u_int st - - and u_PropInfoData st = - u_tup4 u_NamedType u_string u_dtype u_dtypes st - + + and u_PropInfoData st = + u_tup4 u_NamedType u_string u_dtype u_dtypes st + and u_CtorInfoData st = u_tup2 u_NamedType u_dtypes st - - and u_MethodBase st = - let tag = u_byte_as_int st - match tag with - | 0 -> - match u_ModuleDefn st with + + and u_MethodBase st = + let tag = u_byte_as_int st + match tag with + | 0 -> + match u_ModuleDefn st with | Unique(StaticMethodCallOp(minfo)) -> (minfo :> MethodBase) | Unique(StaticPropGetOp(pinfo)) -> (pinfo.GetGetMethod(true) :> MethodBase) | Ambiguous(_) -> raise (System.Reflection.AmbiguousMatchException()) | _ -> failwith "unreachable" - | 1 -> - let ((tc,_,_,methName,_) as data) = u_MethodInfoData st - if methName = ".cctor" then + | 1 -> + let ((tc, _, _, methName, _) as data) = u_MethodInfoData st + if methName = ".cctor" then let cinfo = bindGenericCctor tc (cinfo :> MethodBase) else let minfo = bindGenericMeth(data) (minfo :> MethodBase) - | 2 -> + | 2 -> let data = u_CtorInfoData st - let cinfo = bindGenericCtor(data) in + let cinfo = bindGenericCtor(data) in (cinfo :> MethodBase) - | _ -> failwith "u_MethodBase" + | _ -> failwith "u_MethodBase" - - and u_constSpec st = - let tag = u_byte_as_int st + + and u_constSpec st = + let tag = u_byte_as_int st if tag = 1 then - let bindModuleDefn r tyargs = + let bindModuleDefn r tyargs = match r with - | StaticMethodCallOp(minfo) -> StaticMethodCallOp(instMeth(minfo,tyargs)) + | StaticMethodCallOp(minfo) -> StaticMethodCallOp(instMeth(minfo, tyargs)) // OK to throw away the tyargs here since this only non-generic values in modules get represented by static properties - | x -> x + | x -> x match u_ModuleDefn st with | Unique(r) -> Unique(bindModuleDefn r) - | Ambiguous(f) -> Ambiguous(fun argTypes tyargs -> bindModuleDefn (f argTypes tyargs) tyargs) + | Ambiguous(f) -> Ambiguous(fun argTypes tyargs -> bindModuleDefn (f argTypes tyargs) tyargs) else - let constSpec = - match tag with - | 0 -> u_void st |> (fun () NoTyArgs -> IfThenElseOp) - | 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)) + let constSpec = + match tag with + | 0 -> u_void st |> (fun () NoTyArgs -> IfThenElseOp) + | 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 -> let minfo = bindMeth(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) + | 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 -> let minfo = bindMeth(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) | _ -> failwithf "u_constSpec, unrecognized tag %d" tag Unique constSpec + let u_ReflectedDefinition = u_tup2 u_MethodBase u_Expr + let u_ReflectedDefinitions = u_list u_ReflectedDefinition - let unpickleExpr (localType: Type) referencedTypes bytes = + let unpickleExpr (localType: Type) referencedTypes bytes = unpickleObj localType.Assembly referencedTypes u_Expr bytes - let unpickleReflectedDefns localAssembly referencedTypes bytes = + let unpickleReflectedDefns localAssembly referencedTypes bytes = unpickleObj localAssembly referencedTypes u_ReflectedDefinitions bytes //-------------------------------------------------------------------------- - // General utilities that will eventually be folded into + // General utilities that will eventually be folded into // Microsoft.FSharp.Quotations.Typed //-------------------------------------------------------------------------- - - /// Fill the holes in an Expr - let rec fillHolesInRawExpr (l:Expr[]) (E t as e) = - match t with + + /// Fill the holes in an Expr + 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"; + | 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 + let rec freeInExprAcc bvs acc (E t) = + match t with + | 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 - | LambdaTerm (v,b) -> freeInExprAcc (Set.add v bvs) acc b + | LambdaTerm (v, b) -> freeInExprAcc (Set.add v bvs) acc b and freeInExpr e = freeInExprAcc Set.empty Set.empty e // utility for folding - let foldWhile f st (ie: seq<'T>) = + 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 - + res <- f (match res with Some a -> a | _ -> failwith "internal error") e.Current + res + [] exception Clash of Var /// Replace type variables and expression variables with parameters using the - /// given substitution functions/maps. - let rec substituteInExpr bvs tmsubst (E t as e) = - match t with - | CombTerm (c, args) -> - let substargs = args |> List.map (fun arg -> substituteInExpr bvs tmsubst arg) - EA(CombTerm(c, substargs),e.CustomAttributes) - | VarTerm v -> - match tmsubst v with - | None -> e - | Some e2 -> - let fvs = freeInExpr e2 + /// given substitution functions/maps. + let rec substituteInExpr bvs tmsubst (E t as e) = + match t with + | CombTerm (c, args) -> + let substargs = args |> List.map (fun arg -> substituteInExpr bvs tmsubst arg) + EA(CombTerm(c, substargs), e.CustomAttributes) + | 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)) - | LambdaTerm (v,b) -> - try EA(LambdaTerm(v,substituteInExpr (Set.add v bvs) tmsubst b),e.CustomAttributes) + 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 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) + 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 n = int s.Length - let res = Array.zeroCreate n - let i = ref 0 - while (!i < n) do - i := !i + s.Read(res,!i,(n - !i)) - done; - res + 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)) + res - let decodedTopResources = new Dictionary(10,HashIdentity.Structural) + let decodedTopResources = new Dictionary(10, HashIdentity.Structural) #if !FX_NO_REFLECTION_METADATA_TOKENS #if FX_NO_REFLECTION_MODULE_HANDLES // not available on Silverlight [] type ModuleHandle = ModuleHandle of string * string - type System.Reflection.Module with + type System.Reflection.Module with member x.ModuleHandle = ModuleHandle(x.Assembly.FullName, x.Name) #else type ModuleHandle = System.ModuleHandle #endif #endif - + #if FX_NO_REFLECTION_METADATA_TOKENS // not available on Compact Framework [] - type ReflectedDefinitionTableKey = + type ReflectedDefinitionTableKey = // Key is declaring type * type parameters count * name * parameter types * return type // Registered reflected definitions can contain generic methods or constructors in generic types, // however TryGetReflectedDefinition can be queried with concrete instantiations of the same methods that doesn't contain type parameters. // To make these two cases match we apply the following transformations: // 1. if declaring type is generic - key will contain generic type definition, otherwise - type itself // 2. if method is instantiation of generic one - pick parameters from generic method definition, otherwise - from methods itself - // 3 if method is constructor and declaring type is generic then we'll use the following trick to treat C<'a>() and C() as the same type - // - we resolve method handle of the constructor using generic type definition - as a result for constructor from instantiated type we obtain matching constructor in generic type definition + // 3 if method is constructor and declaring type is generic then we'll use the following trick to treat C<'a>() and C() as the same type + // - we resolve method handle of the constructor using generic type definition - as a result for constructor from instantiated type we obtain matching constructor in generic type definition | Key of System.Type * int * string * System.Type[] * System.Type - static member GetKey(methodBase:MethodBase) = + static member GetKey(methodBase:MethodBase) = let isGenericType = methodBase.DeclaringType.IsGenericType - let declaringType = - if isGenericType then - methodBase.DeclaringType.GetGenericTypeDefinition() + let declaringType = + if isGenericType then + methodBase.DeclaringType.GetGenericTypeDefinition() else methodBase.DeclaringType - let tyArgsCount = - if methodBase.IsGenericMethod then - methodBase.GetGenericArguments().Length + let tyArgsCount = + if methodBase.IsGenericMethod then + methodBase.GetGenericArguments().Length else 0 #if FX_RESHAPED_REFLECTION // this is very unfortunate consequence of limited Reflection capabilities on .NETCore // what we want: having MethodBase for some concrete method or constructor we would like to locate corresponding MethodInfo\ConstructorInfo from the open generic type (canonical form). // It is necessary to build the key for the table of reflected definitions: reflection definition is saved for open generic type but user may request it using // arbitrary instantiation. - let findMethodInOpenGenericType (mb : ('T :> MethodBase)) : 'T = - let candidates = - let bindingFlags = + let findMethodInOpenGenericType (mb : ('T :> MethodBase)) : 'T = + let candidates = + let bindingFlags = (if mb.IsPublic then BindingFlags.Public else BindingFlags.NonPublic) ||| (if mb.IsStatic then BindingFlags.Static else BindingFlags.Instance) let candidates : MethodBase[] = @@ -1703,13 +1737,13 @@ module Patterns = else box (declaringType.GetMethods(bindingFlags)) ) - candidates |> Array.filter (fun c -> - c.Name = mb.Name && + candidates |> Array.filter (fun c -> + c.Name = mb.Name && (c.GetParameters().Length) = (mb.GetParameters().Length) && (c.IsGenericMethod = mb.IsGenericMethod) && (if c.IsGenericMethod then c.GetGenericArguments().Length = mb.GetGenericArguments().Length else true) ) - let solution = + let solution = if candidates.Length = 0 then failwith "Unexpected, failed to locate matching method" elif candidates.Length = 1 then candidates.[0] else @@ -1728,9 +1762,9 @@ module Patterns = // - rate is increased on EXACT_MATCHING_COST if type of argument that candidate has at position i exactly matched the type of argument for the original method. // - rate is increased on GENERIC_TYPE_MATCHING_COST if candidate has generic argument at given position and its type matched the type of argument for the original method. // - otherwise rate will be 0 - let evaluateCandidate (mb : MethodBase) : int = + let evaluateCandidate (mb : MethodBase) : int = let parameters = mb.GetParameters() - let rec loop i resultSoFar = + let rec loop i resultSoFar = if i >= parameters.Length then resultSoFar else let p = parameters.[i] @@ -1745,14 +1779,14 @@ module Patterns = loop 0 0 - Array.maxBy evaluateCandidate candidates + Array.maxBy evaluateCandidate candidates solution :?> 'T #endif match methodBase with | :? MethodInfo as mi -> - let mi = - if mi.IsGenericMethod then + let mi = + if mi.IsGenericMethod then let mi = mi.GetGenericMethodDefinition() if isGenericType then #if FX_RESHAPED_REFLECTION @@ -1766,7 +1800,7 @@ module Patterns = let paramTypes = mi.GetParameters() |> getTypesFromParamInfos Key(declaringType, tyArgsCount, methodBase.Name, paramTypes, mi.ReturnType) | :? ConstructorInfo as ci -> - let mi = + let mi = if isGenericType then #if FX_RESHAPED_REFLECTION findMethodInOpenGenericType ci @@ -1780,216 +1814,216 @@ module Patterns = | _ -> failwithf "Unexpected MethodBase type, %A" (methodBase.GetType()) // per MSDN ConstructorInfo and MethodInfo are the only derived types from MethodBase #else [] - type ReflectedDefinitionTableKey = + type ReflectedDefinitionTableKey = | Key of ModuleHandle * int - static member GetKey(methodBase:MethodBase) = - Key(methodBase.Module.ModuleHandle,methodBase.MetadataToken) + static member GetKey(methodBase:MethodBase) = + Key(methodBase.Module.ModuleHandle, methodBase.MetadataToken) #endif [] 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) -> + let defns = unpickleReflectedDefns assem referencedTypes bytes + defns |> List.iter (fun (minfo, exprBuilder) -> let key = ReflectedDefinitionTableKey.GetKey minfo - lock reflectedDefinitionTable (fun () -> - reflectedDefinitionTable.Add(key,Entry(exprBuilder)))) - decodedTopResources.Add((assem,resourceName),0) + lock reflectedDefinitionTable (fun () -> + reflectedDefinitionTable.Add(key, Entry(exprBuilder)))) + decodedTopResources.Add((assem, resourceName), 0) let tryGetReflectedDefinition (methodBase: MethodBase, tyargs: Type []) = checkNonNull "methodBase" methodBase - let data = + let data = let assem = methodBase.DeclaringType.Assembly let key = ReflectedDefinitionTableKey.GetKey methodBase - let ok,res = lock reflectedDefinitionTable (fun () -> reflectedDefinitionTable.TryGetValue(key)) + 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 + let qdataResources = + // dynamic assemblies don't support the GetManifestResourceNames + match assem with | a when a.FullName = "System.Reflection.Emit.AssemblyBuilder" -> [] - | null | _ -> - let resources = + | 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 + if resourceName.StartsWith(ReflectedDefinitionsResourceNameBase, StringComparison.Ordinal) && + not (decodedTopResources.ContainsKey((assem, resourceName))) then - let cmaAttribForResource = + let cmaAttribForResource = #if FX_RESHAPED_REFLECTION CustomAttributeExtensions.GetCustomAttributes(assem, typeof) |> Seq.toArray #else assem.GetCustomAttributes(typeof, false) #endif |> (function null -> [| |] | x -> x) - |> Array.tryPick (fun ca -> - match ca with - | :? CompilationMappingAttribute as cma when cma.ResourceName = resourceName -> Some cma - | _ -> None) + |> 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 + let referencedTypes = + match cmaAttribForResource with | None -> [| |] | Some cma -> cma.TypeDefinitions - yield (resourceName,unpickleReflectedDefns assem referencedTypes resourceBytes) ] - + yield (resourceName, unpickleReflectedDefns assem referencedTypes resourceBytes) ] + // ok, add to the table - let ok,res = - lock reflectedDefinitionTable (fun () -> + 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.Add((assem,resourceName),0)) + qdataResources + |> List.iter (fun (resourceName, defns) -> + defns |> List.iter (fun (methodBase, exprBuilder) -> + reflectedDefinitionTable.[ReflectedDefinitionTableKey.GetKey methodBase] <- Entry(exprBuilder)) + decodedTopResources.Add((assem, resourceName), 0)) // we know it's in the table now, if it's ever going to be there - reflectedDefinitionTable.TryGetValue(key) - ); + reflectedDefinitionTable.TryGetValue(key) + ) if ok then Some res else None - match data with - | Some (Entry(exprBuilder)) -> - let expectedNumTypars = - getNumGenericArguments(methodBase.DeclaringType) + - (match methodBase with + 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) - if (expectedNumTypars <> tyargs.Length) then - invalidArg "tyargs" (String.Format(SR.GetString(SR.QwrongNumOfTypeArgs), methodBase.Name, expectedNumTypars.ToString(), tyargs.Length.ToString())); + if (expectedNumTypars <> tyargs.Length) then + invalidArg "tyargs" (String.Format(SR.GetString(SR.QwrongNumOfTypeArgs), methodBase.Name, expectedNumTypars.ToString(), tyargs.Length.ToString())) Some(exprBuilder (envClosed tyargs)) | None -> None - let tryGetReflectedDefinitionInstantiated (methodBase:MethodBase) = + let tryGetReflectedDefinitionInstantiated (methodBase:MethodBase) = checkNonNull "methodBase" methodBase - match methodBase with - | :? MethodInfo as minfo -> - let tyargs = + match methodBase with + | :? MethodInfo as minfo -> + let tyargs = Array.append (getGenericArguments minfo.DeclaringType) (if minfo.IsGenericMethod then minfo.GetGenericArguments() else [| |]) tryGetReflectedDefinition (methodBase, tyargs) - | :? ConstructorInfo as cinfo -> + | :? ConstructorInfo as cinfo -> let tyargs = getGenericArguments cinfo.DeclaringType tryGetReflectedDefinition (methodBase, tyargs) - | _ -> + | _ -> tryGetReflectedDefinition (methodBase, [| |]) - let deserialize (localAssembly, referencedTypeDefs, spliceTypes, spliceExprs, bytes) : Expr = + let deserialize (localAssembly, referencedTypeDefs, spliceTypes, spliceExprs, bytes) : 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)) - new Expr<'T>(expr.Tree,expr.CustomAttributes) + + + let cast (expr: Expr) : Expr<'T> = + checkTypesSR (typeof<'T>) (typeOf expr) "expr" (SR.GetString(SR.QtmmExprHasWrongType)) + new Expr<'T>(expr.Tree, expr.CustomAttributes) open Patterns -type Expr with +type Expr with member x.Substitute substitution = substituteRaw substitution x - member x.GetFreeVars () = (freeInExpr x :> seq<_>) - member x.Type = typeOf x + member x.GetFreeVars () = (freeInExpr x :> seq<_>) + member x.Type = typeOf x - static member AddressOf (target:Expr) = - mkAddressOf target + static member AddressOf (target:Expr) = + mkAddressOf target - static member AddressSet (target:Expr, value:Expr) = - mkAddressSet (target,value) + static member AddressSet (target:Expr, value:Expr) = + mkAddressSet (target, value) - static member Application (functionExpr:Expr, argument:Expr) = - mkApplication (functionExpr,argument) + 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) + mkInstanceMethodCall (obj, methodInfo, 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) = + 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 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 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 = + static member NewTuple elements = mkNewTuple 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) - 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)) - 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) - static member PropertySet (property:PropertyInfo, value:Expr, ?indexerArgs) = + static member PropertySet (property:PropertyInfo, value:Expr, ?indexerArgs) = mkStaticPropSet(property, defaultArg indexerArgs [], value) static member Quote (inner:Expr) = mkQuote (inner, true) @@ -1998,71 +2032,71 @@ type Expr with 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) = + static member Value(value: obj, expressionType: Type) = checkNonNull "expressionType" 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) - static member WithValue (value:'T, definition: Expr<'T>) = + static member WithValue (value:'T, definition: Expr<'T>) = let raw = mkValueWithDefn(box value, typeof<'T>, definition) - new Expr<'T>(raw.Tree,raw.CustomAttributes) + new Expr<'T>(raw.Tree, raw.CustomAttributes) - static member WithValue(value: obj, expressionType: Type, definition: Expr) = + static member WithValue(value: obj, expressionType: Type, definition: Expr) = checkNonNull "expressionType" expressionType mkValueWithDefn (value, expressionType, definition) - static member Var(variable) = + 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) = + static member TryGetReflectedDefinition(methodBase:MethodBase) = checkNonNull "methodBase" methodBase tryGetReflectedDefinitionInstantiated(methodBase) static member Cast(source:Expr) = cast source - static member Deserialize(qualifyingType:Type, spliceTypes, spliceExprs, bytes: byte[]) = + static member Deserialize(qualifyingType:Type, spliceTypes, spliceExprs, bytes: byte[]) = checkNonNull "qualifyingType" qualifyingType checkNonNull "bytes" bytes deserialize (qualifyingType, [| |], Array.ofList spliceTypes, Array.ofList spliceExprs, bytes) - static member Deserialize40(qualifyingType:Type, referencedTypes, spliceTypes, spliceExprs, bytes: byte[]) = + static member Deserialize40(qualifyingType:Type, referencedTypes, spliceTypes, spliceExprs, bytes: byte[]) = checkNonNull "spliceExprs" spliceExprs checkNonNull "spliceTypes" spliceTypes checkNonNull "referencedTypeDefs" referencedTypes @@ -2070,14 +2104,14 @@ type Expr with checkNonNull "bytes" bytes deserialize (qualifyingType, referencedTypes, spliceTypes, spliceExprs, bytes) - static member RegisterReflectedDefinitions(assembly, resource, serializedValue) = - Expr.RegisterReflectedDefinitions(assembly, resource, serializedValue, [| |]) + static member RegisterReflectedDefinitions(assembly, resource, serializedValue) = + Expr.RegisterReflectedDefinitions(assembly, resource, serializedValue, [| |]) - static member RegisterReflectedDefinitions(assembly, resource, serializedValue, referencedTypes) = + static member RegisterReflectedDefinitions(assembly, resource, serializedValue, referencedTypes) = checkNonNull "assembly" assembly registerReflectedDefinitions(assembly, resource, serializedValue, referencedTypes) - static member GlobalVar<'T>(name) : Expr<'T> = + static member GlobalVar<'T>(name) : Expr<'T> = checkNonNull "name" name Expr.Var(Var.Global(name, typeof<'T>)) |> Expr.Cast @@ -2086,113 +2120,113 @@ 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. + /// (fun (x, y) -> z) is represented as 'fun p -> let x = p#0 let y = p#1' etc. /// This reverses this encoding. let (|TupledLambda|_|) (lam: Expr) = /// 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 + 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 - | _ -> ([],expr) - match lam.Tree with - | LambdaTerm(v,body) -> - match stripSuccessiveProjLets v 0 body with - | [],b -> Some([v], b) - | letvs,b -> Some(letvs,b) + | _ -> ([], expr) + match lam.Tree with + | 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) -> - match x with - | Unit -> Some(f,[]) - | NewTuple(x) -> Some(f,x) - | x -> Some(f,[x]) + let (|TupledApplication|_|) e = + match e with + | Application(f, x) -> + match x with + | Unit -> Some(f, []) + | NewTuple(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) + let (|AndAlso|_|) input = + match input with + | IfThenElse(x, y, Bool(false)) -> Some(x, y) | _ -> None - + [] - let (|OrElse|_|) input = - match input with - | IfThenElse(x,Bool(true),y) -> Some(x,y) + let (|OrElse|_|) input = + match input with + | IfThenElse(x, Bool(true), y) -> Some(x, y) | _ -> None [] - let (|SpecificCall|_|) templateParameter = + let (|SpecificCall|_|) templateParameter = // Note: precomputation match templateParameter with - | (Lambdas(_,Call(_,minfo1,_)) | Call(_,minfo1,_)) -> - let isg1 = minfo1.IsGenericMethod + | (Lambdas(_, Call(_, minfo1, _)) | Call(_, minfo1, _)) -> + let isg1 = minfo1.IsGenericMethod let gmd = if isg1 then minfo1.GetGenericMethodDefinition() else null // end-of-precomputation - (fun tm -> + (fun tm -> match tm with - | Call(obj,minfo2,args) + | Call(obj, minfo2, args) #if FX_NO_REFLECTION_METADATA_TOKENS when ( // if metadata tokens are not available we'll rely only on equality of method references -#else +#else when (minfo1.MetadataToken = minfo2.MetadataToken && -#endif - if isg1 then +#endif + if isg1 then minfo2.IsGenericMethod && gmd = minfo2.GetGenericMethodDefinition() else - minfo1 = minfo2) -> - Some(obj,(minfo2.GetGenericArguments() |> Array.toList),args) + minfo1 = minfo2) -> + Some(obj, (minfo2.GetGenericArguments() |> Array.toList), args) | _ -> None) - | _ -> + | _ -> invalidArg "templateParameter" (SR.GetString(SR.QunrecognizedMethodCall)) - let private new_decimal_info = + 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 [] - let (|Decimal|_|) input = - match input with + 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 -> @@ -2200,75 +2234,75 @@ module DerivedPatterns = | _ -> None [] - let (|MethodWithReflectedDefinition|_|) (methodBase) = + let (|MethodWithReflectedDefinition|_|) (methodBase) = Expr.TryGetReflectedDefinition(methodBase) - + [] - let (|PropertyGetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = + let (|PropertyGetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = Expr.TryGetReflectedDefinition(propertyInfo.GetGetMethod(true)) [] - let (|PropertySetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = + 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 e = - match op,arguments with - | 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) - | DefaultValueOp(ty),_ -> mkDefaultValue(ty) - | StaticMethodCallOp(minfo),_ -> mkStaticMethodCall(minfo,arguments) - | InstanceMethodCallOp(minfo),obj::args -> mkInstanceMethodCall(obj,minfo,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) - | _ -> raise <| System.InvalidOperationException (SR.GetString(SR.QillFormedAppOrLet)) - - - EA(e.Tree,attrs) + 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) + | 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) + | DefaultValueOp(ty), _ -> mkDefaultValue(ty) + | StaticMethodCallOp(minfo), _ -> mkStaticMethodCall(minfo, arguments) + | InstanceMethodCallOp(minfo), obj::args -> mkInstanceMethodCall(obj, minfo, 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) + | _ -> raise <| System.InvalidOperationException (SR.GetString(SR.QillFormedAppOrLet)) + + + EA(e.Tree, attrs) [] - 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) - | HoleTerm _ -> invalidArg "expr" (SR.GetString(SR.QunexpectedHole)) + 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) + | HoleTerm _ -> invalidArg "expr" (SR.GetString(SR.QunexpectedHole)) loop (input :> Expr) diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs index f0d9c2854c2..14b56e5b4de 100644 --- a/src/fsharp/FSharp.Core/reflect.fs +++ b/src/fsharp/FSharp.Core/reflect.fs @@ -6,6 +6,7 @@ namespace Microsoft.FSharp.Reflection open System +open System.Collections.Generic open System.Reflection open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators @@ -13,7 +14,7 @@ open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Collections open Microsoft.FSharp.Primitives.Basics -module internal ReflectionUtils = +module internal ReflectionUtils = type BindingFlags = System.Reflection.BindingFlags @@ -23,28 +24,28 @@ module internal ReflectionUtils = else BindingFlags.Public - +[] module internal Impl = #if FX_RESHAPED_REFLECTION open PrimReflectionAdapters - open ReflectionAdapters + open ReflectionAdapters #endif let getBindingFlags allowAccess = ReflectionUtils.toBindingFlags (defaultArg allowAccess false) - let inline checkNonNull argName (v: 'T) = - match box v with - | null -> nullArg argName + 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 equivHeadTypes (ty1:Type) (ty2:Type) = + let isNamedType(typ: Type) = not (typ.IsArray || typ.IsByRef || typ.IsPointer) + + let equivHeadTypes (ty1: Type) (ty2: Type) = isNamedType(ty1) && - if ty1.IsGenericType then + if ty1.IsGenericType then ty2.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(ty2.GetGenericTypeDefinition()) - else + else ty1.Equals(ty2) let func = typedefof<(obj -> obj)> @@ -56,59 +57,59 @@ module internal Impl = //----------------------------------------------------------------- // GENERAL UTILITIES #if FX_RESHAPED_REFLECTION - let instanceFieldFlags = BindingFlags.Instance - let instancePropertyFlags = BindingFlags.Instance + let instanceFieldFlags = BindingFlags.Instance + let instancePropertyFlags = BindingFlags.Instance let staticPropertyFlags = BindingFlags.Static - let staticFieldFlags = BindingFlags.Static - let staticMethodFlags = BindingFlags.Static -#else - let instanceFieldFlags = BindingFlags.GetField ||| BindingFlags.Instance - let instancePropertyFlags = BindingFlags.GetProperty ||| BindingFlags.Instance + let staticFieldFlags = BindingFlags.Static + let staticMethodFlags = BindingFlags.Static +#else + let instanceFieldFlags = BindingFlags.GetField ||| BindingFlags.Instance + let instancePropertyFlags = BindingFlags.GetProperty ||| BindingFlags.Instance let staticPropertyFlags = BindingFlags.GetProperty ||| BindingFlags.Static - let staticFieldFlags = BindingFlags.GetField ||| BindingFlags.Static - let staticMethodFlags = BindingFlags.Static + let staticFieldFlags = BindingFlags.GetField ||| BindingFlags.Static + let staticMethodFlags = BindingFlags.Static #endif - 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) = + let getInstancePropertyReader (typ: Type, propName, bindingFlags) = match getInstancePropertyInfo(typ, propName, bindingFlags) with | null -> None #if FX_RESHAPED_REFLECTION - | prop -> Some(fun (obj:obj) -> prop.GetValue(obj,null)) -#else - | prop -> Some(fun (obj:obj) -> prop.GetValue(obj,instancePropertyFlags ||| bindingFlags,null,null,null)) + | prop -> Some(fun (obj: obj) -> prop.GetValue (obj, null)) +#else + | prop -> Some(fun (obj: obj) -> prop.GetValue (obj, instancePropertyFlags ||| bindingFlags, null, null, null)) #endif //----------------------------------------------------------------- // ATTRIBUTE DECOMPILATION - let tryFindCompilationMappingAttribute (attrs:obj[]) = + let tryFindCompilationMappingAttribute (attrs: obj[]) = match attrs with | null | [| |] -> None | [| res |] -> let a = (res :?> CompilationMappingAttribute) in Some (a.SourceConstructFlags, a.SequenceNumber, a.VariantNumber) - | _ -> raise <| System.InvalidOperationException (SR.GetString(SR.multipleCompilationMappings)) + | _ -> raise <| System.InvalidOperationException (SR.GetString (SR.multipleCompilationMappings)) - let findCompilationMappingAttribute (attrs:obj[]) = + let findCompilationMappingAttribute (attrs: obj[]) = match tryFindCompilationMappingAttribute attrs with | None -> failwith "no compilation mapping attribute" | Some a -> a #if !FX_NO_REFLECTION_ONLY let cmaName = typeof.FullName - let assemblyName = typeof.Assembly.GetName().Name + let assemblyName = typeof.Assembly.GetName().Name let _ = assert (assemblyName = "FSharp.Core") - - let tryFindCompilationMappingAttributeFromData (attrs:System.Collections.Generic.IList) = + + let tryFindCompilationMappingAttributeFromData (attrs: IList) = match attrs with | null -> None - | _ -> + | _ -> let mutable res = None for a in attrs do - if a.Constructor.DeclaringType.FullName = cmaName then + if a.Constructor.DeclaringType.FullName = cmaName then let args = a.ConstructorArguments - let flags = - match args.Count with + 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)) @@ -120,55 +121,55 @@ module internal Impl = match tryFindCompilationMappingAttributeFromData attrs with | None -> failwith "no compilation mapping attribute" | Some a -> a -#endif +#endif - let tryFindCompilationMappingAttributeFromType (typ:Type) = + let tryFindCompilationMappingAttributeFromType (typ: Type) = #if !FX_NO_REFLECTION_ONLY let assem = typ.Assembly - if (not (isNull assem)) && assem.ReflectionOnly then + if (not (isNull assem)) && assem.ReflectionOnly then tryFindCompilationMappingAttributeFromData ( typ.GetCustomAttributesData()) else #endif - tryFindCompilationMappingAttribute ( typ.GetCustomAttributes (typeof,false)) + tryFindCompilationMappingAttribute ( typ.GetCustomAttributes (typeof, false)) - let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = + let tryFindCompilationMappingAttributeFromMemberInfo (info: MemberInfo) = #if !FX_NO_REFLECTION_ONLY let assem = info.DeclaringType.Assembly - if (not (isNull assem)) && assem.ReflectionOnly then + if (not (isNull assem)) && assem.ReflectionOnly then tryFindCompilationMappingAttributeFromData (info.GetCustomAttributesData()) else #endif - tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof,false)) + tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof, false)) - let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = + let findCompilationMappingAttributeFromMemberInfo (info: MemberInfo) = #if !FX_NO_REFLECTION_ONLY let assem = info.DeclaringType.Assembly - if (not (isNull assem)) && assem.ReflectionOnly then + if (not (isNull assem)) && assem.ReflectionOnly then findCompilationMappingAttributeFromData (info.GetCustomAttributesData()) else #endif - 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 variantNumberOfMember (x: MemberInfo) = let (_, _, vn) = findCompilationMappingAttributeFromMemberInfo x in vn 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 + | Some (flags, _n, _vn) -> (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Field - let tryFindSourceConstructFlagsOfType (typ:Type) = - match tryFindCompilationMappingAttributeFromType typ with + let tryFindSourceConstructFlagsOfType (typ: Type) = + match tryFindCompilationMappingAttributeFromType typ with | None -> None - | Some (flags,_n,_vn) -> Some flags + | Some (flags, _n, _vn) -> Some flags //----------------------------------------------------------------- - // UNION DECOMPILATION + // UNION DECOMPILATION // Get the type where the type definitions are stored - let getUnionCasesTyp (typ: Type, _bindingFlags) = + let getUnionCasesTyp (typ: Type, _bindingFlags) = #if CASES_IN_NESTED_CLASS let casesTyp = typ.GetNestedType("Cases", bindingFlags) if casesTyp.IsGenericTypeDefinition then casesTyp.MakeGenericType(typ.GetGenericArguments()) @@ -176,39 +177,39 @@ module internal Impl = #else typ #endif - - let getUnionTypeTagNameMap (typ:Type,bindingFlags) = + + let getUnionTypeTagNameMap (typ: Type, bindingFlags) = let enumTyp = typ.GetNestedType("Tags", bindingFlags) // Unions with a singleton case do not get a Tags type (since there is only one tag), hence enumTyp may be null in this case match enumTyp with - | null -> - typ.GetMethods(staticMethodFlags ||| bindingFlags) - |> Array.choose (fun minfo -> + | null -> + typ.GetMethods(staticMethodFlags ||| bindingFlags) + |> Array.choose (fun minfo -> match tryFindCompilationMappingAttributeFromMemberInfo(minfo) with | None -> None - | Some (flags,n,_vn) -> - if (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.UnionCase then - let nm = minfo.Name - // chop "get_" or "New" off the front - let nm = - if not (isListType typ) && not (isOptionType typ) then - if nm.Length > 4 && nm.[0..3] = "get_" then nm.[4..] + | Some (flags, n, _vn) -> + if (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.UnionCase then + let nm = minfo.Name + // chop "get_" or "New" off the front + let nm = + if not (isListType typ) && not (isOptionType typ) then + if nm.Length > 4 && nm.[0..3] = "get_" then nm.[4..] elif nm.Length > 3 && nm.[0..2] = "New" then nm.[3..] else nm else nm Some (n, nm) else - None) - | _ -> - enumTyp.GetFields(staticFieldFlags ||| bindingFlags) - |> Array.filter (fun (f:FieldInfo) -> f.IsStatic && f.IsLiteral) - |> sortFreshArray (fun f1 f2 -> compare (f1.GetValue(null) :?> int) (f2.GetValue(null) :?> int)) - |> 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) - if tagFields.Length = 1 then + None) + | _ -> + enumTyp.GetFields(staticFieldFlags ||| bindingFlags) + |> Array.filter (fun (f: FieldInfo) -> f.IsStatic && f.IsLiteral) + |> sortFreshArray (fun f1 f2 -> compare (f1.GetValue (null) :?> int) (f2.GetValue (null) :?> int)) + |> 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) + if tagFields.Length = 1 then typ else // special case: two-cased DU annotated with CompilationRepresentation(UseNullAsTrueValue) @@ -216,7 +217,7 @@ 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 @@ -226,165 +227,187 @@ module internal Impl = else let casesTyp = getUnionCasesTyp (typ, bindingFlags) let caseTyp = casesTyp.GetNestedType(tagField, bindingFlags) // if this is null then the union is nullary - match caseTyp with + 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))) - else - let tagfieldmap = getUnionTypeTagNameMap (typ,bindingFlags) |> Map.ofSeq + 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))) + else + 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 + 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 + (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then (bindingFlags &&& BindingFlags.NonPublic) <> enum(0) - else + 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:Type,bindingFlags:BindingFlags) = - let rec get (typ:Type) = isUnionType (typ,bindingFlags) || match typ.BaseType with null -> false | b -> get b - get typ + let isConstructorRepr (typ, bindingFlags) = + let rec get typ = isUnionType (typ, bindingFlags) || match typ.BaseType with null -> false | b -> get b + get typ - let unionTypeOfUnionCaseType (typ:Type,bindingFlags) = - let rec get (typ:Type) = if isUnionType (typ,bindingFlags) then typ else match typ.BaseType with null -> typ | b -> get b + let unionTypeOfUnionCaseType (typ, bindingFlags) = + 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:Type, tag:int, bindingFlags) = - if isOptionType typ then - match tag with - | 0 (* None *) -> getInstancePropertyInfos (typ,[| |],bindingFlags) - | 1 (* Some *) -> getInstancePropertyInfos (typ,[| "Value" |],bindingFlags) + let fieldsPropsOfUnionCase (typ, tag, bindingFlags) = + if isOptionType typ then + match tag with + | 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) + elif isListType typ then + match tag with + | 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 - caseTyp.GetProperties(instancePropertyFlags ||| bindingFlags) + 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) + + let getUnionCaseRecordReader (typ: Type, tag: int, bindingFlags) = + let props = fieldsPropsOfUnionCase (typ, tag, bindingFlags) #if FX_RESHAPED_REFLECTION - (fun (obj:obj) -> props |> Array.map (fun prop -> prop.GetValue(obj,null))) -#else - (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, null))) +#else + (fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue (obj, bindingFlags, null, null, null))) #endif - let getUnionTagReader (typ:Type,bindingFlags) : (obj -> int) = - if isOptionType typ then - (fun (obj:obj) -> match obj with null -> 0 | _ -> 1) + let getUnionTagReader (typ: Type, bindingFlags) : (obj -> int) = + if isOptionType typ then + (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 -> - (fun (obj:obj) -> + 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 -> + (fun (obj: obj) -> #if FX_RESHAPED_REFLECTION let m2b = typ.GetMethod("GetTag", [| typ |]) -#else +#else let m2b = typ.GetMethod("GetTag", BindingFlags.Static ||| bindingFlags, null, [| typ |], null) -#endif +#endif m2b.Invoke(null, [|obj|]) :?> int) - - let getUnionTagMemberInfo (typ:Type,bindingFlags) = - match getInstancePropertyInfo (typ,"Tag",bindingFlags) with + + let getUnionTagMemberInfo (typ: Type, bindingFlags) = + match getInstancePropertyInfo (typ, "Tag", bindingFlags) with #if FX_RESHAPED_REFLECTION | null -> (typ.GetMethod("GetTag") :> MemberInfo) -#else - | null -> (typ.GetMethod("GetTag",BindingFlags.Static ||| bindingFlags) :> MemberInfo) -#endif +#else + | null -> (typ.GetMethod("GetTag", BindingFlags.Static ||| bindingFlags) :> MemberInfo) +#endif | info -> (info :> MemberInfo) - let isUnionCaseNullary (typ:Type, tag:int, bindingFlags) = + let isUnionCaseNullary (typ: Type, tag: int, bindingFlags) = fieldsPropsOfUnionCase(typ, tag, bindingFlags).Length = 0 - let getUnionCaseConstructorMethod (typ:Type,tag:int,bindingFlags) = - let constrname = getUnionTagConverter (typ,bindingFlags) tag - let methname = - if isUnionCaseNullary (typ, tag, bindingFlags) then "get_" + constrname + 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 match typ.GetMethod(methname, BindingFlags.Static ||| bindingFlags) with - | null -> raise <| System.InvalidOperationException (String.Format(SR.GetString(SR.constructorForUnionCaseNotFound), methname)) + | null -> raise <| System.InvalidOperationException (String.Format (SR.GetString (SR.constructorForUnionCaseNotFound), methname)) | meth -> meth - let getUnionCaseConstructor (typ:Type,tag:int,bindingFlags) = - let meth = getUnionCaseConstructorMethod (typ,tag,bindingFlags) - (fun args -> + let getUnionCaseConstructor (typ: Type, tag: int, bindingFlags) = + let meth = getUnionCaseConstructorMethod (typ, tag, bindingFlags) + (fun args -> #if FX_RESHAPED_REFLECTION - meth.Invoke(null,args)) -#else - meth.Invoke(null,BindingFlags.Static ||| BindingFlags.InvokeMethod ||| bindingFlags,null,args,null)) + meth.Invoke(null, args)) +#else + meth.Invoke(null, BindingFlags.Static ||| BindingFlags.InvokeMethod ||| bindingFlags, null, args, null)) #endif - let checkUnionType(unionType,bindingFlags) = - checkNonNull "unionType" unionType; - if not (isUnionType (unionType,bindingFlags)) then - if isUnionType (unionType,bindingFlags ||| BindingFlags.NonPublic) then - invalidArg "unionType" (String.Format(SR.GetString(SR.privateUnionType), unionType.FullName)) + let 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)) 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"; |] - - let isTupleType (typ:Type) = - // We need to be careful that we only rely typ.IsGenericType, typ.Namespace and typ.Name here. - // - // Historically the FSharp.Core reflection utilities get used on implementations of - // 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 + 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" |] + + let isTupleType (typ: Type) = + // We need to be careful that we only rely typ.IsGenericType, typ.Namespace and typ.Name here. + // + // Historically the FSharp.Core reflection utilities get used on implementations of + // 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 let maxTuple = 8 // Which field holds the nested tuple? let tupleEncField = maxTuple - 1 let dictionaryLock = obj() - let refTupleTypes = System.Collections.Generic.Dictionary() - let valueTupleTypes = System.Collections.Generic.Dictionary() + let refTupleTypes = Dictionary() + let valueTupleTypes = Dictionary() - let rec mkTupleType isStruct (asm:Assembly) (tys:Type[]) = + let rec mkTupleType isStruct (asm: Assembly) (tys: Type[]) = let table = let makeIt n = let tupleFullName n = @@ -401,7 +424,7 @@ 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 match lock dictionaryLock (fun () -> tables.TryGetValue(asm)) with @@ -409,9 +432,10 @@ module internal Impl = // the Dictionary<>s here could be ConcurrentDictionary<>'s, but then // that would lock while initializing the Type array (maybe not an issue) let a = ref (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)) + lock dictionaryLock (fun () -> + match tables.TryGetValue(asm) with + | true, t -> a := t + | false, _ -> tables.Add(asm, !a)) !a | true, t -> t @@ -428,19 +452,20 @@ module internal Impl = let tysB = tys.[maxTuple-1..] let tyB = mkTupleType isStruct asm tysB table.[7].MakeGenericType(Array.append tysA [| tyB |]) - | _ -> invalidArg "tys" (SR.GetString(SR.invalidTupleTypes)) + | _ -> invalidArg "tys" (SR.GetString (SR.invalidTupleTypes)) + + let rec getTupleTypeInfo (typ: Type) = + if not (isTupleType typ) then + invalidArg "typ" (String.Format (SR.GetString (SR.notATupleType), typ.FullName)) + let tyargs = typ.GetGenericArguments() + if tyargs.Length = maxTuple then + let tysA = tyargs.[0..tupleEncField-1] + let tyB = tyargs.[tupleEncField] + Array.append tysA (getTupleTypeInfo tyB) + else + tyargs - let rec getTupleTypeInfo (typ:Type) = - if not (isTupleType (typ) ) then 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 tyB = tyargs.[tupleEncField] - Array.append tysA (getTupleTypeInfo tyB) - else - tyargs - - let orderTupleProperties (props:PropertyInfo[]) = + let orderTupleProperties (props: PropertyInfo[]) = // The tuple properties are of the form: // Item1 // .. @@ -454,7 +479,7 @@ module internal Impl = #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 + let expectNames = Array.init props.Length (fun i -> let j = i+1 // index j = 1, 2, .., props.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 + let expectNames = Array.init fields.Length (fun i -> let j = i+1 // index j = 1, 2, .., fields.Length <= maxTuple if j orderTupleFields #if FX_RESHAPED_REFLECTION typ.GetConstructor(fields |> Array.map (fun fi -> fi.FieldType)) #else - typ.GetConstructor(BindingFlags.Public ||| BindingFlags.Instance,null,fields |> Array.map (fun fi -> fi.FieldType),null) + typ.GetConstructor(BindingFlags.Public ||| BindingFlags.Instance, null, fields |> Array.map (fun fi -> fi.FieldType), null) #endif else let props = typ.GetProperties() |> orderTupleProperties #if FX_RESHAPED_REFLECTION typ.GetConstructor(props |> Array.map (fun p -> p.PropertyType)) #else - typ.GetConstructor(BindingFlags.Public ||| BindingFlags.Instance,null,props |> Array.map (fun p -> p.PropertyType),null) + typ.GetConstructor(BindingFlags.Public ||| BindingFlags.Instance, null, props |> Array.map (fun p -> p.PropertyType), null) #endif 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 getTupleCtor(typ: Type) = let ctor = getTupleConstructorMethod typ - (fun (args:obj[]) -> -#if FX_RESHAPED_REFLECTION + (fun (args: obj[]) -> +#if FX_RESHAPED_REFLECTION ctor.Invoke(args)) #else ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public, null, args, null)) #endif - let rec getTupleReader (typ:Type) = - let etys = typ.GetGenericArguments() + let rec getTupleReader (typ: Type) = + let etys = typ.GetGenericArguments() // Get the reader for the outer tuple record let reader = if typ.IsValueType then let fields = (typ.GetFields (instanceFieldFlags ||| BindingFlags.Public) |> orderTupleFields) - ((fun (obj:obj) -> fields |> Array.map (fun field -> field.GetValue(obj)))) + ((fun (obj: obj) -> fields |> Array.map (fun field -> field.GetValue (obj)))) else - let props = (typ.GetProperties(instancePropertyFlags ||| BindingFlags.Public) |> orderTupleProperties) - ((fun (obj:obj) -> props |> Array.map (fun prop -> prop.GetValue(obj,null)))) - if etys.Length < maxTuple + let props = (typ.GetProperties (instancePropertyFlags ||| BindingFlags.Public) |> orderTupleProperties) + ((fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue (obj, null)))) + if etys.Length < maxTuple then reader else let tyBenc = etys.[tupleEncField] @@ -534,511 +559,519 @@ module internal Impl = let encVals = reader2 directVals.[tupleEncField] Array.append directVals.[0..tupleEncField-1] encVals) - let rec getTupleConstructor (typ:Type) = - let etys = typ.GetGenericArguments() + let rec getTupleConstructor (typ: Type) = + let etys = typ.GetGenericArguments() let maker1 = getTupleCtor typ - if etys.Length < maxTuple + if etys.Length < maxTuple then maker1 else let tyBenc = etys.[tupleEncField] let maker2 = getTupleConstructor(tyBenc) - (fun (args:obj[]) -> + (fun (args: obj[]) -> let encVal = maker2 args.[tupleEncField..] maker1 (Array.append args.[0..tupleEncField-1] [| encVal |])) - - let getTupleConstructorInfo (typ:Type) = - let etys = typ.GetGenericArguments() + + let getTupleConstructorInfo (typ: Type) = + let etys = typ.GetGenericArguments() let maker1 = getTupleConstructorMethod typ if etys.Length < maxTuple then - maker1,None + maker1, None else - maker1,Some(etys.[tupleEncField]) + maker1, Some(etys.[tupleEncField]) - let getTupleReaderInfo (typ:Type,index:int) = - if index < 0 then invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + let getTupleReaderInfo (typ: Type, index: int) = + if index < 0 then + 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 - if index >= props.Length then invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) + if index >= props.Length then + invalidArg "index" (String.Format (SR.GetString (SR.tupleIndexOutOfRange), typ.FullName, index.ToString())) props.[index] else 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())) + if index >= props.Length then + 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)) - //----------------------------------------------------------------- - // FUNCTION DECOMPILATION - - - let getFunctionTypeInfo (typ:Type) = - if not (isFunctionType typ) then invalidArg "typ" (String.Format(SR.GetString(SR.notAFunctionType), typ.FullName)) + 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] - //----------------------------------------------------------------- - // MODULE DECOMPILATION - - let isModuleType (typ:Type) = - 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) + let isModuleType (typ: Type) = + match tryFindSourceConstructFlagsOfType typ with + | None -> false + | Some(flags) -> + (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Module - //----------------------------------------------------------------- - // RECORD DECOMPILATION - - let isRecordType (typ:Type,bindingFlags:BindingFlags) = - match tryFindSourceConstructFlagsOfType(typ) with - | None -> false + let rec isClosureRepr typ = + 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 + (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then (bindingFlags &&& BindingFlags.NonPublic) <> enum(0) - else + else true) - let fieldPropsOfRecordType(typ:Type,bindingFlags) = - typ.GetProperties(instancePropertyFlags ||| bindingFlags) + 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 getRecordReader(typ: Type, bindingFlags) = + let props = fieldPropsOfRecordType(typ, bindingFlags) + (fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue (obj, null))) - let getRecordConstructorMethod(typ:Type,bindingFlags) = - let props = fieldPropsOfRecordType(typ,bindingFlags) + let getRecordConstructorMethod(typ: Type, bindingFlags) = + let props = fieldPropsOfRecordType(typ, bindingFlags) #if FX_RESHAPED_REFLECTION let ctor = typ.GetConstructor(props |> Array.map (fun p -> p.PropertyType)) -#else - let ctor = typ.GetConstructor(BindingFlags.Instance ||| bindingFlags,null,props |> Array.map (fun p -> p.PropertyType),null) -#endif +#else + let ctor = typ.GetConstructor(BindingFlags.Instance ||| bindingFlags, null, props |> Array.map (fun p -> p.PropertyType), null) +#endif 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[]) -> + let getRecordConstructor(typ: Type, bindingFlags) = + let ctor = getRecordConstructorMethod(typ, bindingFlags) + (fun (args: obj[]) -> #if FX_RESHAPED_REFLECTION ctor.Invoke(args)) -#else - ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| bindingFlags,null,args,null)) -#endif - - //----------------------------------------------------------------- - // EXCEPTION DECOMPILATION - +#else + ctor.Invoke(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| bindingFlags, null, args, null)) +#endif + /// EXCEPTION DECOMPILATION // Check the base type - if it is also an F# type then // for the moment we know it is a Discriminated Union - let isExceptionRepr (typ:Type,bindingFlags) = - match tryFindSourceConstructFlagsOfType(typ) with - | None -> false - | Some(flags) -> + let isExceptionRepr (typ: Type, bindingFlags) = + 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 + (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then (bindingFlags &&& BindingFlags.NonPublic) <> enum(0) - else + else true) - let getTypeOfReprType (typ:Type,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 + let getTypeOfReprType (typ: Type, 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 //----------------------------------------------------------------- // CHECKING ROUTINES 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)) + if not (isExceptionRepr (exceptionType, bindingFlags)) then + if isExceptionRepr (exceptionType, bindingFlags ||| BindingFlags.NonPublic) then + invalidArg "exceptionType" (String.Format (SR.GetString (SR.privateExceptionType), exceptionType.FullName)) else - 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 isRecordType (recordType,bindingFlags ||| BindingFlags.NonPublic) then - invalidArg argName (String.Format(SR.GetString(SR.privateRecordType), recordType.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 isRecordType (recordType, bindingFlags ||| BindingFlags.NonPublic) then + invalidArg argName (String.Format (SR.GetString (SR.privateRecordType), recordType.FullName)) else - invalidArg argName (String.Format(SR.GetString(SR.notARecordType), recordType.FullName)) - - 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.notARecordType), recordType.FullName)) + + let checkTupleType(argName, (tupleType: Type)) = + checkNonNull argName tupleType + if not (isTupleType tupleType) then + invalidArg argName (String.Format (SR.GetString (SR.notATupleType), tupleType.FullName)) #if FX_RESHAPED_REFLECTION open ReflectionAdapters #endif - + [] -type UnionCaseInfo(typ: System.Type, tag:int) = +type UnionCaseInfo(typ: System.Type, tag: int) = + // Cache the tag -> name map let mutable names = None - let getMethInfo() = Impl.getUnionCaseConstructorMethod (typ, tag, BindingFlags.Public ||| BindingFlags.NonPublic) - member __.Name = - match names with - | None -> (let conv = Impl.getUnionTagConverter (typ,BindingFlags.Public ||| BindingFlags.NonPublic) in names <- Some conv; conv tag) - | Some conv -> conv tag - + + let getMethInfo() = getUnionCaseConstructorMethod (typ, tag, BindingFlags.Public ||| BindingFlags.NonPublic) + + member __.Name = + match names with + | None -> + let conv = getUnionTagConverter (typ, BindingFlags.Public ||| BindingFlags.NonPublic) + names <- Some conv + conv tag + | Some conv -> + conv tag + member __.DeclaringType = typ - member __.GetFields() = - let props = Impl.fieldsPropsOfUnionCase(typ,tag,BindingFlags.Public ||| BindingFlags.NonPublic) - props + member __.GetFields() = + fieldsPropsOfUnionCase (typ, tag, BindingFlags.Public ||| BindingFlags.NonPublic) - member __.GetCustomAttributes() = getMethInfo().GetCustomAttributes(false) + member __.GetCustomAttributes() = + getMethInfo().GetCustomAttributes(false) - member __.GetCustomAttributes(attributeType) = getMethInfo().GetCustomAttributes(attributeType,false) + member __.GetCustomAttributes(attributeType) = + getMethInfo().GetCustomAttributes(attributeType, false) - member __.GetCustomAttributesData() = getMethInfo().CustomAttributes |> Seq.toArray :> System.Collections.Generic.IList<_> + member __.GetCustomAttributesData() = + getMethInfo().CustomAttributes |> Seq.toArray :> IList<_> member __.Tag = tag + override x.ToString() = typ.Name + "." + x.Name + override x.GetHashCode() = typ.GetHashCode() + tag - override __.Equals(obj:obj) = - match obj with + + override __.Equals(obj: obj) = + match obj with | :? UnionCaseInfo as uci -> uci.DeclaringType = typ && uci.Tag = tag | _ -> false - [] -type FSharpType = +type FSharpType = - static member IsTuple(typ:Type) = - Impl.checkNonNull "typ" typ - Impl.isTupleType typ + static member IsTuple(typ: Type) = + checkNonNull "typ" typ + isTupleType typ - static member IsRecord(typ:Type,?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - - Impl.checkNonNull "typ" typ - Impl.isRecordType (typ,bindingFlags) + static member IsRecord(typ: Type, ?bindingFlags) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "typ" typ + isRecordType (typ, bindingFlags) - static member IsUnion(typ:Type,?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "typ" typ - let typ = Impl.getTypeOfReprType (typ,BindingFlags.Public ||| BindingFlags.NonPublic) - Impl.isUnionType (typ,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) = - Impl.checkNonNull "typ" typ - let typ = Impl.getTypeOfReprType (typ,BindingFlags.Public ||| BindingFlags.NonPublic) - Impl.isFunctionType typ + static member IsFunction (typ: Type) = + checkNonNull "typ" typ + let typ = getTypeOfReprType (typ, BindingFlags.Public ||| BindingFlags.NonPublic) + isFunctionType typ - static member IsModule(typ:Type) = - Impl.checkNonNull "typ" typ - Impl.isModuleType typ + static member IsModule (typ: Type) = + checkNonNull "typ" typ + isModuleType typ - static member MakeFunctionType(domain:Type,range:Type) = - Impl.checkNonNull "domain" domain - Impl.checkNonNull "range" range - Impl.func.MakeGenericType [| domain; range |] + static member MakeFunctionType (domain: Type, range: Type) = + checkNonNull "domain" domain + checkNonNull "range" range + func.MakeGenericType [| domain; range |] - static member MakeTupleType(types:Type[]) = - Impl.checkNonNull "types" types + 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)) - Impl.mkTupleType false asm types - - static member MakeTupleType (asm:Assembly, types:Type[]) = - Impl.checkNonNull "types" types - if types |> Array.exists (function null -> true | _ -> false) then - invalidArg "types" (SR.GetString(SR.nullsNotAllowedInArray)) - Impl.mkTupleType false asm types - - static member MakeStructTupleType (asm:Assembly, types:Type[]) = - Impl.checkNonNull "types" types - if types |> Array.exists (function null -> true | _ -> false) then - invalidArg "types" (SR.GetString(SR.nullsNotAllowedInArray)) - Impl.mkTupleType true asm types - - static member GetTupleElements(tupleType:Type) = - Impl.checkTupleType("tupleType",tupleType) - Impl.getTupleTypeInfo tupleType - - static member GetFunctionElements(functionType:Type) = - Impl.checkNonNull "functionType" functionType - let functionType = Impl.getTypeOfReprType (functionType,BindingFlags.Public ||| BindingFlags.NonPublic) - Impl.getFunctionTypeInfo functionType - - static member GetRecordFields(recordType:Type,?bindingFlags) = + 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[]) = + checkNonNull "types" types + 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[]) = + checkNonNull "types" types + 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) + getTupleTypeInfo tupleType + + static member GetFunctionElements (functionType: Type) = + checkNonNull "functionType" functionType + let functionType = getTypeOfReprType (functionType, BindingFlags.Public ||| BindingFlags.NonPublic) + getFunctionTypeInfo functionType + + static member GetRecordFields (recordType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkRecordType("recordType",recordType,bindingFlags) - Impl.fieldPropsOfRecordType(recordType,bindingFlags) + checkRecordType ("recordType", recordType, bindingFlags) + fieldPropsOfRecordType(recordType, bindingFlags) - static member GetUnionCases (unionType:Type,?bindingFlags) = + static member GetUnionCases (unionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionType" unionType - let unionType = Impl.getTypeOfReprType (unionType,bindingFlags) - Impl.checkUnionType(unionType,bindingFlags); - Impl.getUnionTypeTagNameMap(unionType,bindingFlags) |> Array.mapi (fun i _ -> UnionCaseInfo(unionType,i)) + 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) = + static member IsExceptionRepresentation (exceptionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "exceptionType" exceptionType - Impl.isExceptionRepr(exceptionType,bindingFlags) + checkNonNull "exceptionType" exceptionType + isExceptionRepr (exceptionType, bindingFlags) - static member GetExceptionFields(exceptionType:Type, ?bindingFlags) = + static member GetExceptionFields (exceptionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "exceptionType" exceptionType - Impl.checkExnType(exceptionType,bindingFlags) - Impl.fieldPropsOfRecordType (exceptionType,bindingFlags) + checkNonNull "exceptionType" exceptionType + checkExnType (exceptionType, bindingFlags) + fieldPropsOfRecordType (exceptionType, bindingFlags) -type DynamicFunction<'T1,'T2>() = +type DynamicFunction<'T1, 'T2>() = inherit FSharpFunc obj, obj>() - override __.Invoke(impl: obj -> obj) : obj = + override __.Invoke(impl: obj -> obj) : obj = box<('T1 -> 'T2)> (fun inp -> unbox<'T2>(impl (box<'T1>(inp)))) [] -type FSharpValue = +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 + + static member GetRecordField(record: obj, info: PropertyInfo) = + 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) + + static member GetRecordFields (record: obj, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkRecordType("recordType",recordType,bindingFlags) - Impl.getRecordConstructor (recordType,bindingFlags) values + checkNonNull "record" record + let typ = record.GetType() + if not (isRecordType (typ, bindingFlags)) then + invalidArg "record" (SR.GetString (SR.objIsNotARecord)) + getRecordReader (typ, bindingFlags) record - static member GetRecordField(record:obj,info:PropertyInfo) = - Impl.checkNonNull "info" info; - Impl.checkNonNull "record" record; - let reprty = record.GetType() - if not (Impl.isRecordType(reprty,BindingFlags.Public ||| BindingFlags.NonPublic)) then invalidArg "record" (SR.GetString(SR.objIsNotARecord)); - info.GetValue(record,null) + static member PreComputeRecordFieldReader(info: PropertyInfo) = + checkNonNull "info" info + (fun (obj: obj) -> info.GetValue (obj, null)) - static member GetRecordFields(record:obj,?bindingFlags) = + static member PreComputeRecordReader(recordType: Type, ?bindingFlags) : (obj -> obj[]) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "record" record - let typ = record.GetType() - if not (Impl.isRecordType(typ,bindingFlags)) then invalidArg "record" (SR.GetString(SR.objIsNotARecord)); - Impl.getRecordReader (typ,bindingFlags) record - - static member PreComputeRecordFieldReader(info:PropertyInfo) = - Impl.checkNonNull "info" info - (fun (obj:obj) -> info.GetValue(obj,null)) - - static member PreComputeRecordReader(recordType:Type,?bindingFlags) : (obj -> obj[]) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkRecordType("recordType",recordType,bindingFlags) - Impl.getRecordReader (recordType,bindingFlags) - - static member PreComputeRecordConstructor(recordType:Type,?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkRecordType("recordType",recordType,bindingFlags) - Impl.getRecordConstructor (recordType,bindingFlags) - - static member PreComputeRecordConstructorInfo(recordType:Type, ?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkRecordType("recordType",recordType,bindingFlags) - Impl.getRecordConstructorMethod(recordType,bindingFlags) - - static member MakeFunction(functionType:Type,implementation:(obj->obj)) = - Impl.checkNonNull "functionType" functionType - if not (Impl.isFunctionType functionType) then invalidArg "functionType" (String.Format(SR.GetString(SR.notAFunctionType), functionType.FullName)); - Impl.checkNonNull "implementation" implementation - let domain,range = Impl.getFunctionTypeInfo functionType - let dynCloMakerTy = typedefof> + checkRecordType ("recordType", recordType, bindingFlags) + getRecordReader (recordType, bindingFlags) + + static member PreComputeRecordConstructor(recordType: Type, ?bindingFlags) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkRecordType ("recordType", recordType, bindingFlags) + getRecordConstructor (recordType, bindingFlags) + + static member PreComputeRecordConstructorInfo(recordType: Type, ?bindingFlags) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkRecordType ("recordType", recordType, bindingFlags) + getRecordConstructorMethod(recordType, bindingFlags) + + 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)) + 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 f implementation - static member MakeTuple(tupleElements: obj[], tupleType:Type) = - Impl.checkNonNull "tupleElements" tupleElements - Impl.checkTupleType("tupleType",tupleType) - Impl.getTupleConstructor tupleType tupleElements - - static member GetTupleFields(tuple:obj) = // argument name(s) used in error message - Impl.checkNonNull "tuple" tuple - let typ = tuple.GetType() - if not (Impl.isTupleType typ ) then invalidArg "tuple" (String.Format(SR.GetString(SR.notATupleType), tuple.GetType().FullName)); - Impl.getTupleReader typ tuple - - static member GetTupleField(tuple:obj,index:int) = // argument name(s) used in error message - Impl.checkNonNull "tuple" tuple - let typ = tuple.GetType() - if not (Impl.isTupleType typ ) then invalidArg "tuple" (String.Format(SR.GetString(SR.notATupleType), tuple.GetType().FullName)); - let fields = Impl.getTupleReader typ tuple - if index < 0 || index >= fields.Length then invalidArg "index" (String.Format(SR.GetString(SR.tupleIndexOutOfRange), tuple.GetType().FullName, index.ToString())); + static member MakeTuple(tupleElements: obj[], tupleType: Type) = + checkNonNull "tupleElements" tupleElements + 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)) + 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)) + 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())) fields.[index] - - static member PreComputeTupleReader(tupleType:Type) : (obj -> obj[]) = - Impl.checkTupleType("tupleType",tupleType) - Impl.getTupleReader tupleType - - static member PreComputeTuplePropertyInfo(tupleType:Type,index:int) = - Impl.checkTupleType("tupleType",tupleType) - Impl.getTupleReaderInfo (tupleType,index) - - static member PreComputeTupleConstructor(tupleType:Type) = - Impl.checkTupleType("tupleType",tupleType) - Impl.getTupleConstructor tupleType - - static member PreComputeTupleConstructorInfo(tupleType:Type) = - Impl.checkTupleType("tupleType",tupleType) - Impl.getTupleConstructorInfo (tupleType) - - static member MakeUnion(unionCase:UnionCaseInfo,args: obj [],?bindingFlags) = + + static member PreComputeTupleReader(tupleType: Type) : (obj -> obj[]) = + checkTupleType("tupleType", tupleType) + getTupleReader tupleType + + static member PreComputeTuplePropertyInfo(tupleType: Type, index: int) = + checkTupleType("tupleType", tupleType) + getTupleReaderInfo (tupleType, index) + + static member PreComputeTupleConstructor(tupleType: Type) = + checkTupleType("tupleType", tupleType) + getTupleConstructor tupleType + + static member PreComputeTupleConstructorInfo(tupleType: Type) = + checkTupleType("tupleType", tupleType) + getTupleConstructorInfo tupleType + + 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) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "unionCase" unionCase + getUnionCaseConstructor (unionCase.DeclaringType, unionCase.Tag, bindingFlags) + + static member PreComputeUnionConstructorInfo(unionCase: UnionCaseInfo, ?bindingFlags) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "unionCase" unionCase + getUnionCaseConstructorMethod (unionCase.DeclaringType, unionCase.Tag, bindingFlags) + + static member GetUnionFields(value: obj, unionType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionCase" unionCase; - Impl.getUnionCaseConstructor (unionCase.DeclaringType,unionCase.Tag,bindingFlags) args - - static member PreComputeUnionConstructor (unionCase:UnionCaseInfo,?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionCase" unionCase; - Impl.getUnionCaseConstructor (unionCase.DeclaringType,unionCase.Tag,bindingFlags) - - static member PreComputeUnionConstructorInfo(unionCase:UnionCaseInfo, ?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionCase" unionCase; - Impl.getUnionCaseConstructorMethod (unionCase.DeclaringType,unionCase.Tag,bindingFlags) - - 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)) + let ensureType (typ: Type, obj: obj) = + match typ with + | null -> + match obj with + | null -> invalidArg "obj" (SR.GetString (SR.objIsNullAndNoType)) | _ -> obj.GetType() - | _ -> typ - - let unionType = ensureType(unionType,value) - - Impl.checkNonNull "unionType" unionType - let unionType = Impl.getTypeOfReprType (unionType,bindingFlags) - - Impl.checkUnionType(unionType,bindingFlags) - let tag = Impl.getUnionTagReader (unionType,bindingFlags) value - let flds = Impl.getUnionCaseRecordReader (unionType,tag,bindingFlags) value - UnionCaseInfo(unionType,tag), flds - - static member PreComputeUnionTagReader(unionType: Type,?bindingFlags) : (obj -> int) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionType" unionType - let unionType = Impl.getTypeOfReprType (unionType,bindingFlags) - Impl.checkUnionType(unionType,bindingFlags) - Impl.getUnionTagReader (unionType,bindingFlags) - - static member PreComputeUnionTagMemberInfo(unionType: Type,?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionType" unionType; - let unionType = Impl.getTypeOfReprType (unionType,bindingFlags) - Impl.checkUnionType(unionType,bindingFlags) - Impl.getUnionTagMemberInfo(unionType,bindingFlags) - - static member PreComputeUnionReader(unionCase: UnionCaseInfo,?bindingFlags) : (obj -> obj[]) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "unionCase" unionCase - let typ = unionCase.DeclaringType - Impl.getUnionCaseRecordReader (typ,unionCase.Tag,bindingFlags) - - static member GetExceptionFields(exn:obj, ?bindingFlags) = - let bindingFlags = defaultArg bindingFlags BindingFlags.Public - Impl.checkNonNull "exn" exn; - let typ = exn.GetType() - Impl.checkExnType(typ,bindingFlags) - Impl.getRecordReader (typ,bindingFlags) exn + | _ -> typ + + let unionType = ensureType(unionType, value) + + checkNonNull "unionType" unionType + let unionType = getTypeOfReprType (unionType, bindingFlags) + + checkUnionType (unionType, bindingFlags) + let tag = getUnionTagReader (unionType, bindingFlags) value + let flds = getUnionCaseRecordReader (unionType, tag, bindingFlags) value + UnionCaseInfo (unionType, tag), flds + + static member PreComputeUnionTagReader(unionType: Type, ?bindingFlags) : (obj -> int) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "unionType" unionType + let unionType = getTypeOfReprType (unionType, bindingFlags) + checkUnionType (unionType, bindingFlags) + getUnionTagReader (unionType, bindingFlags) + + static member PreComputeUnionTagMemberInfo(unionType: Type, ?bindingFlags) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "unionType" unionType + let unionType = getTypeOfReprType (unionType, bindingFlags) + checkUnionType (unionType, bindingFlags) + getUnionTagMemberInfo (unionType, bindingFlags) + + static member PreComputeUnionReader(unionCase: UnionCaseInfo, ?bindingFlags) : (obj -> obj[]) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "unionCase" unionCase + let typ = unionCase.DeclaringType + getUnionCaseRecordReader (typ, unionCase.Tag, bindingFlags) + + static member GetExceptionFields (exn: obj, ?bindingFlags) = + let bindingFlags = defaultArg bindingFlags BindingFlags.Public + checkNonNull "exn" exn + let typ = exn.GetType() + checkExnType (typ, bindingFlags) + getRecordReader (typ, bindingFlags) exn module FSharpReflectionExtensions = type FSharpType with - static member GetExceptionFields(exceptionType:Type, ?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpType.GetExceptionFields(exceptionType, bindingFlags) + static member GetExceptionFields (exceptionType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpType.GetExceptionFields (exceptionType, bindingFlags) - static member IsExceptionRepresentation(exceptionType:Type, ?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpType.IsExceptionRepresentation(exceptionType, bindingFlags) + static member IsExceptionRepresentation(exceptionType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpType.IsExceptionRepresentation (exceptionType, bindingFlags) - static member GetUnionCases (unionType:Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpType.GetUnionCases(unionType, bindingFlags) + static member GetUnionCases (unionType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpType.GetUnionCases (unionType, bindingFlags) - static member GetRecordFields(recordType:Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpType.GetRecordFields(recordType, bindingFlags) + static member GetRecordFields (recordType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpType.GetRecordFields (recordType, bindingFlags) - static member IsUnion(typ:Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpType.IsUnion(typ, bindingFlags) + static member IsUnion (typ: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpType.IsUnion (typ, bindingFlags) - static member IsRecord(typ:Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpType.IsRecord(typ, bindingFlags) + static member IsRecord(typ: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpType.IsRecord (typ, bindingFlags) type FSharpValue with - static member MakeRecord(recordType:Type,values,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.MakeRecord(recordType, values, bindingFlags) + static member MakeRecord(recordType: Type, values, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.MakeRecord (recordType, values, bindingFlags) - static member GetRecordFields(record:obj,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.GetRecordFields(record, bindingFlags) + static member GetRecordFields (record: obj, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.GetRecordFields (record, bindingFlags) - static member PreComputeRecordReader(recordType:Type,?allowAccessToPrivateRepresentation) : (obj -> obj[]) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeRecordReader(recordType, bindingFlags) + static member PreComputeRecordReader(recordType: Type, ?allowAccessToPrivateRepresentation) : (obj -> obj[]) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeRecordReader (recordType, bindingFlags) - static member PreComputeRecordConstructor(recordType:Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeRecordConstructor(recordType, bindingFlags) + static member PreComputeRecordConstructor(recordType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeRecordConstructor (recordType, bindingFlags) - static member PreComputeRecordConstructorInfo(recordType:Type, ?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeRecordConstructorInfo(recordType, bindingFlags) + static member PreComputeRecordConstructorInfo(recordType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeRecordConstructorInfo (recordType, bindingFlags) - static member MakeUnion(unionCase:UnionCaseInfo,args: obj [],?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.MakeUnion(unionCase, args, bindingFlags) + static member MakeUnion(unionCase: UnionCaseInfo, args: obj [], ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.MakeUnion (unionCase, args, bindingFlags) - static member PreComputeUnionConstructor (unionCase:UnionCaseInfo,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionConstructor(unionCase, bindingFlags) + static member PreComputeUnionConstructor (unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeUnionConstructor (unionCase, bindingFlags) - static member PreComputeUnionConstructorInfo(unionCase:UnionCaseInfo, ?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionConstructorInfo(unionCase, bindingFlags) + static member PreComputeUnionConstructorInfo(unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeUnionConstructorInfo (unionCase, bindingFlags) - static member PreComputeUnionTagMemberInfo(unionType: Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionTagMemberInfo(unionType, bindingFlags) + static member PreComputeUnionTagMemberInfo(unionType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeUnionTagMemberInfo (unionType, bindingFlags) - static member GetUnionFields(value:obj,unionType:Type,?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.GetUnionFields(value, unionType, bindingFlags) + static member GetUnionFields(value: obj, unionType: Type, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.GetUnionFields (value, unionType, bindingFlags) - static member PreComputeUnionTagReader(unionType: Type,?allowAccessToPrivateRepresentation) : (obj -> int) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionTagReader(unionType, bindingFlags) + static member PreComputeUnionTagReader(unionType: Type, ?allowAccessToPrivateRepresentation) : (obj -> int) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeUnionTagReader (unionType, bindingFlags) - static member PreComputeUnionReader(unionCase: UnionCaseInfo,?allowAccessToPrivateRepresentation) : (obj -> obj[]) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.PreComputeUnionReader(unionCase, bindingFlags) + static member PreComputeUnionReader(unionCase: UnionCaseInfo, ?allowAccessToPrivateRepresentation) : (obj -> obj[]) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.PreComputeUnionReader (unionCase, bindingFlags) - static member GetExceptionFields(exn:obj, ?allowAccessToPrivateRepresentation) = - let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation - FSharpValue.GetExceptionFields(exn, bindingFlags) + static member GetExceptionFields (exn: obj, ?allowAccessToPrivateRepresentation) = + let bindingFlags = getBindingFlags allowAccessToPrivateRepresentation + FSharpValue.GetExceptionFields (exn, bindingFlags) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 394bc4963de..9ab21f29fc3 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -2,858 +2,879 @@ namespace Microsoft.FSharp.Collections - open System - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Collections - open System.Collections - open System.Collections.Generic - open System.Diagnostics - - (* A classic functional language implementation of binary trees *) - - [] - [] - type SetTree<'T> when 'T: comparison = - | SetEmpty // height = 0 - | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int - | SetOne of 'T // height = 1 - // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) - // REVIEW: performance rumour has it that the data held in SetNode and SetOne should be - // exactly one cache line on typical architectures. They are currently - // ~6 and 3 words respectively. - - - [] - module internal SetTree = - let rec countAux s acc = - match s with - | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) - | SetOne(_) -> acc+1 - | SetEmpty -> acc - - let count s = countAux s 0 - - #if TRACE_SETS_AND_MAPS - let mutable traceCount = 0 - let mutable numOnes = 0 - let mutable numNodes = 0 - let mutable numAdds = 0 - let mutable numRemoves = 0 - let mutable numLookups = 0 - let mutable numUnions = 0 - let mutable totalSizeOnNodeCreation = 0.0 - let mutable totalSizeOnSetAdd = 0.0 - let mutable totalSizeOnSetLookup = 0.0 - 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,(totalSizeOnNodeCreation / float (numNodes + numOnes)),(totalSizeOnSetAdd / float numAdds),(totalSizeOnSetLookup / float numLookups)) - - let SetOne n = - report(); - numOnes <- numOnes + 1; - totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0; - SetTree.SetOne n - - let SetNode (x,l,r,h) = - report(); - numNodes <- numNodes + 1; - let n = SetTree.SetNode(x,l,r,h) - totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (count n); - n - #else - let SetOne n = SetTree.SetOne n - let SetNode (x,l,r,h) = SetTree.SetNode(x,l,r,h) - - #endif - - - let height t = - match t with - | SetEmpty -> 0 - | SetOne _ -> 1 - | SetNode (_,_,_,h) -> h - - #if CHECKED - let rec checkInvariant t = - // A good sanity check, loss of balance can hit perf - match t with - | SetEmpty -> true - | SetOne _ -> true - | SetNode (k,t1,t2,h) -> - let h1 = height t1 - let h2 = height t2 - (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 - #endif - - let tolerance = 2 - - let mk l k r = - match l,r with - | SetEmpty,SetEmpty -> SetOne (k) - | _ -> - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - SetNode(k,l,r,m+1) - - let rebalance t1 k t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + tolerance then // right is heavier than left - match t2 with - | SetNode(t2k,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - if height t2l > t1h + 1 then // balance left: combination - match t2l with - | SetNode(t2lk,t2ll,t2lr,_) -> - mk (mk t1 k t2ll) t2lk (mk t2lr t2k t2r) - | _ -> failwith "rebalance" - else // rotate left - mk (mk t1 k t2l) t2k t2r - | _ -> failwith "rebalance" - else - if t1h > t2h + tolerance then // left is heavier than right - match t1 with - | SetNode(t1k,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - if height t1r > t2h + 1 then - // balance right: combination - match t1r with - | SetNode(t1rk,t1rl,t1rr,_) -> - mk (mk t1l t1k t1rl) t1rk (mk t1rr k t2) - | _ -> failwith "rebalance" - else - mk t1l t1k (mk t1r k t2) - | _ -> failwith "rebalance" - else mk t1 k t2 - - let rec add (comparer: IComparer<'T>) k t = - match t with - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k l) k2 r - elif c = 0 then t - else rebalance l k2 (add comparer k r) - | SetOne(k2) -> - // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - let c = comparer.Compare(k,k2) - if c < 0 then SetNode (k,SetEmpty,t,2) - elif c = 0 then t - else SetNode (k,t,SetEmpty,2) - | SetEmpty -> SetOne(k) - - let rec balance comparer t1 k t2 = - // 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" - match t1,t2 with - | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty - | t1,SetEmpty -> add comparer k t1 // drop t2 = empty - | SetOne k1,t2 -> add comparer k (add comparer k1 t2) - | t1,SetOne k2 -> add comparer k (add comparer k2 t1) - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> - // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) - // 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 h1+tolerance < h2 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 t21) k2 t22 - elif h2+tolerance < h1 then - // case: c, h2 too small - // push t2 into high side of t1, may increase height by 1 so rebalance - rebalance t11 k1 (balance comparer t12 k t2) - else - // case: a, h1 and h2 meet balance requirement - mk t1 k t2 - - let rec split (comparer: IComparer<'T>) pivot 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 } - match t with - | SetNode(k1,t11,t12,_) -> - let c = comparer.Compare(pivot,k1) - if c < 0 then // pivot t1 - let t11Lo,havePivot,t11Hi = split comparer pivot t11 - t11Lo,havePivot,balance comparer t11Hi k1 t12 - elif c = 0 then // pivot is k1 - t11,true,t12 - else // pivot t2 - let t12Lo,havePivot,t12Hi = split comparer pivot t12 - balance comparer t11 k1 t12Lo,havePivot,t12Hi - | SetOne k1 -> - let c = comparer.Compare(k1,pivot) - if c < 0 then t,false,SetEmpty // singleton under pivot - elif c = 0 then SetEmpty,true,SetEmpty // singleton is pivot - else SetEmpty,false,t // singleton over pivot - | SetEmpty -> - SetEmpty,false,SetEmpty - - let rec spliceOutSuccessor t = - match t with - | SetEmpty -> failwith "internal error: Set.spliceOutSuccessor" - | SetOne (k2) -> k2,SetEmpty - | SetNode (k2,l,r,_) -> - match l with - | SetEmpty -> k2,r - | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' k2 r - - let rec remove (comparer: IComparer<'T>) k t = - match t with - | SetEmpty -> t - | SetOne (k2) -> - let c = comparer.Compare(k,k2) - if c = 0 then SetEmpty - else t - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (remove comparer k l) k2 r - elif c = 0 then - match l,r with - | SetEmpty,_ -> r - | _,SetEmpty -> l - | _ -> - let sk,r' = spliceOutSuccessor r - mk l sk r' - else rebalance l k2 (remove comparer k r) - - let rec mem (comparer: IComparer<'T>) k t = - match t with - | SetNode(k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then mem comparer k l - elif c = 0 then true - else mem comparer k r - | SetOne(k2) -> (comparer.Compare(k,k2) = 0) - | SetEmpty -> false - - let rec iter f t = - match t with - | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r - | SetOne(k2) -> f k2 - | SetEmpty -> () - - let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m x = - match m with - | SetNode(k,l,r,_) -> foldBackOpt f l (f.Invoke(k, (foldBackOpt f r x))) - | SetOne(k) -> f.Invoke(k, x) - | SetEmpty -> x - - let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m x - - let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) x m = - match m with - | SetNode(k,l,r,_) -> - let x = foldOpt f x l in - let x = f.Invoke(x, k) - foldOpt f x r - | SetOne(k) -> f.Invoke(x, k) - | SetEmpty -> x +open System +open System.Collections +open System.Collections.Generic +open System.Diagnostics +open System.Text +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Collections + +// A functional language implementation of binary trees + +[] +[] +type SetTree<'T> when 'T: comparison = + | SetEmpty // height = 0 + | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int + | SetOne of 'T // height = 1 + // OPTIMIZATION: store SetNode (k, SetEmpty, SetEmpty, 1) ---> SetOne (k) + +[] +module internal SetTree = + let rec countAux s acc = + match s with + | SetNode (_, l, r, _) -> countAux l (countAux r (acc+1)) + | SetOne (_) -> acc+1 + | SetEmpty -> acc + + let count s = countAux s 0 - let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) x m +#if TRACE_SETS_AND_MAPS + let mutable traceCount = 0 + let mutable numOnes = 0 + let mutable numNodes = 0 + let mutable numAdds = 0 + let mutable numRemoves = 0 + let mutable numLookups = 0 + let mutable numUnions = 0 + let mutable totalSizeOnNodeCreation = 0.0 + let mutable totalSizeOnSetAdd = 0.0 + let mutable totalSizeOnSetLookup = 0.0 + + 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, + (totalSizeOnNodeCreation / float (numNodes + numOnes)), + (totalSizeOnSetAdd / float numAdds), + (totalSizeOnSetLookup / float numLookups)) + + let SetOne n = + report() + numOnes <- numOnes + 1 + totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 + SetTree.SetOne n + + let SetNode (x, l, r, h) = + report() + numNodes <- numNodes + 1 + let n = SetTree.SetNode (x, l, r, h) + totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (count n) + n +#else + let SetOne n = SetTree.SetOne n + + let SetNode (x, l, r, h) = SetTree.SetNode (x, l, r, h) +#endif - let rec forall f m = - match m with - | SetNode(k2,l,r,_) -> f k2 && forall f l && forall f r - | SetOne(k2) -> f k2 - | SetEmpty -> true + let height t = + match t with + | SetEmpty -> 0 + | SetOne _ -> 1 + | SetNode (_, _, _, h) -> h + +#if CHECKED + let rec checkInvariant t = + // A good sanity check, loss of balance can hit perf + match t with + | SetEmpty -> true + | SetOne _ -> true + | SetNode (k, t1, t2, h) -> + let h1 = height t1 + let h2 = height t2 + (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 +#endif - let rec exists f m = + let tolerance = 2 + + let mk l k r = + match l, r with + | SetEmpty, SetEmpty -> SetOne (k) + | _ -> + let hl = height l + let hr = height r + let m = if hl < hr then hr else hl + SetNode (k, l, r, m+1) + + let rebalance t1 k t2 = + let t1h = height t1 + let t2h = height t2 + if t2h > t1h + tolerance then // right is heavier than left + match t2 with + | SetNode (t2k, t2l, t2r, _) -> + // one of the nodes must have height > height t1 + 1 + if height t2l > t1h + 1 then // balance left: combination + match t2l with + | SetNode (t2lk, t2ll, t2lr, _) -> + mk (mk t1 k t2ll) t2lk (mk t2lr t2k t2r) + | _ -> failwith "rebalance" + else // rotate left + mk (mk t1 k t2l) t2k t2r + | _ -> failwith "rebalance" + else + if t1h > t2h + tolerance then // left is heavier than right + match t1 with + | SetNode (t1k, t1l, t1r, _) -> + // one of the nodes must have height > height t2 + 1 + if height t1r > t2h + 1 then + // balance right: combination + match t1r with + | SetNode (t1rk, t1rl, t1rr, _) -> + mk (mk t1l t1k t1rl) t1rk (mk t1rr k t2) + | _ -> failwith "rebalance" + else + mk t1l t1k (mk t1r k t2) + | _ -> failwith "rebalance" + else mk t1 k t2 + + let rec add (comparer: IComparer<'T>) k t = + match t with + | SetNode (k2, l, r, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then rebalance (add comparer k l) k2 r + elif c = 0 then t + else rebalance l k2 (add comparer k r) + | SetOne k2 -> + // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated + let c = comparer.Compare(k, k2) + if c < 0 then SetNode (k, SetEmpty, t, 2) + elif c = 0 then t + else SetNode (k, t, SetEmpty, 2) + | SetEmpty -> SetOne k + + let rec balance comparer t1 k t2 = + // 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" + match t1, t2 with + | SetEmpty, t2 -> add comparer k t2 // drop t1 = empty + | t1, SetEmpty -> add comparer k t1 // drop t2 = empty + | SetOne k1, t2 -> add comparer k (add comparer k1 t2) + | t1, SetOne k2 -> add comparer k (add comparer k2 t1) + | SetNode (k1, t11, t12, h1), SetNode (k2, t21, t22, h2) -> + // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) + // 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 h1+tolerance < h2 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 t21) k2 t22 + elif h2+tolerance < h1 then + // case: c, h2 too small + // push t2 into high side of t1, may increase height by 1 so rebalance + rebalance t11 k1 (balance comparer t12 k t2) + else + // case: a, h1 and h2 meet balance requirement + mk t1 k t2 + + let rec split (comparer: IComparer<'T>) pivot 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 } + match t with + | SetNode (k1, t11, t12, _) -> + let c = comparer.Compare(pivot, k1) + if c < 0 then // pivot t1 + let t11Lo, havePivot, t11Hi = split comparer pivot t11 + t11Lo, havePivot, balance comparer t11Hi k1 t12 + elif c = 0 then // pivot is k1 + t11, true, t12 + else // pivot t2 + let t12Lo, havePivot, t12Hi = split comparer pivot t12 + balance comparer t11 k1 t12Lo, havePivot, t12Hi + | SetOne k1 -> + let c = comparer.Compare(k1, pivot) + if c < 0 then t, false, SetEmpty // singleton under pivot + elif c = 0 then SetEmpty, true, SetEmpty // singleton is pivot + else SetEmpty, false, t // singleton over pivot + | SetEmpty -> + SetEmpty, false, SetEmpty + + let rec spliceOutSuccessor t = + match t with + | SetEmpty -> failwith "internal error: Set.spliceOutSuccessor" + | SetOne (k2) -> k2, SetEmpty + | SetNode (k2, l, r, _) -> + match l with + | SetEmpty -> k2, r + | _ -> let k3, l' = spliceOutSuccessor l in k3, mk l' k2 r + + let rec remove (comparer: IComparer<'T>) k t = + match t with + | SetEmpty -> t + | SetOne (k2) -> + let c = comparer.Compare(k, k2) + if c = 0 then SetEmpty + else t + | SetNode (k2, l, r, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then rebalance (remove comparer k l) k2 r + elif c = 0 then + match l, r with + | SetEmpty, _ -> r + | _, SetEmpty -> l + | _ -> + let sk, r' = spliceOutSuccessor r + mk l sk r' + else rebalance l k2 (remove comparer k r) + + let rec mem (comparer: IComparer<'T>) k t = + match t with + | SetNode (k2, l, r, _) -> + let c = comparer.Compare(k, k2) + if c < 0 then mem comparer k l + elif c = 0 then true + else mem comparer k r + | SetOne (k2) -> (comparer.Compare(k, k2) = 0) + | SetEmpty -> false + + let rec iter f t = + match t with + | SetNode (k2, l, r, _) -> iter f l; f k2; iter f r + | SetOne (k2) -> f k2 + | SetEmpty -> () + + let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) m x = + match m with + | SetNode (k, l, r, _) -> foldBackOpt f l (f.Invoke(k, (foldBackOpt f r x))) + | SetOne (k) -> f.Invoke(k, x) + | SetEmpty -> x + + let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) m x + + let rec foldOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) x m = + match m with + | SetNode (k, l, r, _) -> + let x = foldOpt f x l in + let x = f.Invoke(x, k) + foldOpt f x r + | SetOne (k) -> f.Invoke(x, k) + | SetEmpty -> x + + let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f)) x m + + let rec forall f m = + match m with + | SetNode (k2, l, r, _) -> f k2 && forall f l && forall f r + | SetOne (k2) -> f k2 + | SetEmpty -> true + + let rec exists f m = + match m with + | SetNode (k2, l, r, _) -> f k2 || exists f l || exists f r + | SetOne (k2) -> f k2 + | SetEmpty -> false + + let isEmpty m = match m with | SetEmpty -> true | _ -> false + + 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 rec filterAux comparer f s acc = + match s with + | SetNode (k, l, r, _) -> + let acc = if f k then add comparer k acc else acc + filterAux comparer f l (filterAux comparer f r acc) + | SetOne (k) -> if f k then add comparer k acc else acc + | SetEmpty -> acc + + let filter comparer f s = filterAux comparer f s SetEmpty + + let rec diffAux comparer m acc = + match acc with + | SetEmpty -> acc + | _ -> + match m with + | SetNode (k, l, r, _) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) + | SetOne (k) -> remove comparer k acc + | SetEmpty -> acc + + let diff comparer a b = diffAux comparer b a + + let rec union comparer t1 t2 = + // Perf: tried bruteForce for low heights, but nothing significant + match t1, t2 with + | SetNode (k1, t11, t12, h1), SetNode (k2, t21, t22, h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) + // Divide and Conquer: + // Suppose t1 is largest. + // Split t2 using pivot k1 into lo and hi. + // Union disjoint subproblems and then combine. + if h1 > h2 then + let lo, _, hi = split comparer k1 t2 in + balance comparer (union comparer t11 lo) k1 (union comparer t12 hi) + else + let lo, _, hi = split comparer k2 t1 in + balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) + | SetEmpty, t -> t + | t, SetEmpty -> t + | SetOne k1, t2 -> add comparer k1 t2 + | t1, SetOne k2 -> add comparer k2 t1 + + let rec intersectionAux comparer b m acc = + match m with + | SetNode (k, l, r, _) -> + let acc = intersectionAux comparer b r acc + let acc = if mem comparer k b then add comparer k acc else acc + intersectionAux comparer b l acc + | SetOne (k) -> + if mem comparer k b then add comparer k acc else acc + | SetEmpty -> acc + + let intersection comparer a b = intersectionAux comparer b a SetEmpty + + let partition1 comparer f k (acc1, acc2) = if f k then (add comparer k acc1, acc2) else (acc1, add comparer k acc2) + + let rec partitionAux comparer f s acc = + match s with + | SetNode (k, l, r, _) -> + let acc = partitionAux comparer f r acc + let acc = partition1 comparer f k acc + partitionAux comparer f l acc + | SetOne (k) -> partition1 comparer f k acc + | SetEmpty -> acc + + let partition comparer f s = partitionAux comparer f s (SetEmpty, SetEmpty) + + // It's easier to get many less-important algorithms right using this active pattern + let (|MatchSetNode|MatchSetEmpty|) s = + match s with + | SetNode (k2, l, r, _) -> MatchSetNode(k2, l, r) + | SetOne (k2) -> MatchSetNode(k2, SetEmpty, SetEmpty) + | SetEmpty -> MatchSetEmpty + + let rec minimumElementAux s n = + match s with + | SetNode (k, l, _, _) -> minimumElementAux l k + | SetOne (k) -> k + | SetEmpty -> n + + and minimumElementOpt s = + match s with + | SetNode (k, l, _, _) -> Some(minimumElementAux l k) + | SetOne (k) -> Some k + | SetEmpty -> None + + and maximumElementAux s n = + match s with + | SetNode (k, _, r, _) -> maximumElementAux r k + | SetOne (k) -> k + | SetEmpty -> n + + and maximumElementOpt s = + match s with + | SetNode (k, _, r, _) -> Some(maximumElementAux r k) + | SetOne (k) -> Some(k) + | SetEmpty -> None + + let minimumElement s = + match minimumElementOpt s with + | Some(k) -> k + | None -> invalidArg "s" (SR.GetString(SR.setContainsNoElements)) + + let maximumElement s = + match maximumElementOpt s with + | Some(k) -> k + | 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 + } + + // collapseLHS: + // a) Always returns either [] or a list starting with SetOne. + // b) The "fringe" of the set stack is unchanged. + let rec collapseLHS stack = + match stack with + | [] -> [] + | SetEmpty :: rest -> collapseLHS rest + | SetOne _ :: _ -> stack + | SetNode (k, l, r, _) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) + + let mkIterator s = { stack = collapseLHS [s]; started = false } + + let notStarted() = raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) + + let alreadyFinished() = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + + let current i = + if i.started then + match i.stack with + | SetOne k :: _ -> k + | [] -> alreadyFinished() + | _ -> failwith "Please report error: Set iterator, unexpected stack for current" + else + notStarted() + + let rec moveNext i = + if i.started then + match i.stack with + | SetOne _ :: rest -> + i.stack <- collapseLHS rest + not i.stack.IsEmpty + | [] -> false + | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" + else + i.started <- true; // The first call to MoveNext "starts" the enumeration. + not i.stack.IsEmpty + + let mkIEnumerator s = + let i = ref (mkIterator s) + { 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() = () } + + /// Set comparison. Note this can be expensive. + let rec compareStacks (comparer: IComparer<'T>) l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | (SetEmpty _ :: t1), (SetEmpty :: t2) -> compareStacks comparer t1 t2 + | (SetOne (n1k) :: t1), (SetOne (n2k) :: t2) -> + let c = comparer.Compare(n1k, n2k) + if c <> 0 then c else compareStacks comparer t1 t2 + | (SetOne (n1k) :: t1), (SetNode (n2k, SetEmpty, n2r, _) :: t2) -> + let c = comparer.Compare(n1k, n2k) + if c <> 0 then c else compareStacks comparer (SetEmpty :: t1) (n2r :: t2) + | (SetNode (n1k, (SetEmpty as emp), n1r, _) :: t1), (SetOne (n2k) :: t2) -> + let c = comparer.Compare(n1k, n2k) + if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) + | (SetNode (n1k, SetEmpty, n1r, _) :: t1), (SetNode (n2k, SetEmpty, n2r, _) :: t2) -> + let c = comparer.Compare(n1k, n2k) + if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) + | (SetOne (n1k) :: t1), _ -> + compareStacks comparer (SetEmpty :: SetOne (n1k) :: t1) l2 + | (SetNode (n1k, n1l, n1r, _) :: t1), _ -> + compareStacks comparer (n1l :: SetNode (n1k, SetEmpty, n1r, 0) :: t1) l2 + | _, (SetOne (n2k) :: t2) -> + compareStacks comparer l1 (SetEmpty :: SetOne (n2k) :: t2) + | _, (SetNode (n2k, n2l, n2r, _) :: t2) -> + compareStacks comparer l1 (n2l :: SetNode (n2k, SetEmpty, n2r, 0) :: t2) + + let compare comparer s1 s2 = + match s1, s2 with + | SetEmpty, SetEmpty -> 0 + | SetEmpty, _ -> -1 + | _, SetEmpty -> 1 + | _ -> compareStacks comparer [s1] [s2] + + let choose s = + minimumElement s + + let toList s = + let rec loop m acc = match m with - | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r - | SetOne(k2) -> f k2 - | SetEmpty -> false - - let isEmpty m = match m with | SetEmpty -> true | _ -> false - - let subset comparer a b = forall (fun x -> mem comparer x b) a - - let psubset comparer a b = forall (fun x -> mem comparer x b) a && exists (fun x -> not (mem comparer x a)) b + | SetNode (k, l, r, _) -> loop l (k :: loop r acc) + | SetOne (k) -> k ::acc + | SetEmpty -> acc + loop s [] - let rec filterAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = if f k then add comparer k acc else acc - filterAux comparer f l (filterAux comparer f r acc) - | SetOne(k) -> if f k then add comparer k acc else acc - | SetEmpty -> acc + let copyToArray s (arr: _[]) i = + let j = ref i + iter (fun x -> arr.[!j] <- x; j := !j + 1) s - let filter comparer f s = filterAux comparer f s SetEmpty + let toArray s = + let n = (count s) + let res = Array.zeroCreate n + copyToArray s res 0 + res - let rec diffAux comparer m acc = - match acc with - | SetEmpty -> acc - | _ -> - match m with - | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) - | SetOne(k) -> remove comparer k acc - | SetEmpty -> acc - - let diff comparer a b = diffAux comparer b a - - let rec union comparer t1 t2 = - // Perf: tried bruteForce for low heights, but nothing significant - match t1,t2 with - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) - // Divide and Conquer: - // Suppose t1 is largest. - // Split t2 using pivot k1 into lo and hi. - // Union disjoint subproblems and then combine. - if h1 > h2 then - let lo,_,hi = split comparer k1 t2 in - balance comparer (union comparer t11 lo) k1 (union comparer t12 hi) - else - let lo,_,hi = split comparer k2 t1 in - balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) - | SetEmpty,t -> t - | t,SetEmpty -> t - | SetOne k1,t2 -> add comparer k1 t2 - | t1,SetOne k2 -> add comparer k2 t1 - - let rec intersectionAux comparer b m acc = - match m with - | SetNode(k,l,r,_) -> - let acc = intersectionAux comparer b r acc - let acc = if mem comparer k b then add comparer k acc else acc - intersectionAux comparer b l acc - | SetOne(k) -> - if mem comparer k b then add comparer k acc else acc - | SetEmpty -> acc - - let intersection comparer a b = intersectionAux comparer b a SetEmpty - - let partition1 comparer f k (acc1,acc2) = if f k then (add comparer k acc1,acc2) else (acc1,add comparer k acc2) - - let rec partitionAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = partitionAux comparer f r acc - let acc = partition1 comparer f k acc - partitionAux comparer f l acc - | SetOne(k) -> partition1 comparer f k acc - | SetEmpty -> acc - - let partition comparer f s = partitionAux comparer f s (SetEmpty,SetEmpty) - - // It's easier to get many less-important algorithms right using this active pattern - let (|MatchSetNode|MatchSetEmpty|) s = - match s with - | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) - | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) - | SetEmpty -> MatchSetEmpty - - let rec minimumElementAux s n = - match s with - | SetNode(k,l,_,_) -> minimumElementAux l k - | SetOne(k) -> k - | SetEmpty -> n - - and minimumElementOpt s = - match s with - | SetNode(k,l,_,_) -> Some(minimumElementAux l k) - | SetOne(k) -> Some k - | SetEmpty -> None - - and maximumElementAux s n = - match s with - | SetNode(k,_,r,_) -> maximumElementAux r k - | SetOne(k) -> k - | SetEmpty -> n - - and maximumElementOpt s = - match s with - | SetNode(k,_,r,_) -> Some(maximumElementAux r k) - | SetOne(k) -> Some(k) - | SetEmpty -> None - - let minimumElement s = - match minimumElementOpt s with - | Some(k) -> k - | None -> invalidArg "s" (SR.GetString(SR.setContainsNoElements)) - - let maximumElement s = - match maximumElementOpt s with - | Some(k) -> k - | 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 - } - - // collapseLHS: - // a) Always returns either [] or a list starting with SetOne. - // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = - match stack with - | [] -> [] - | SetEmpty :: rest -> collapseLHS rest - | SetOne _ :: _ -> stack - | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) - - let mkIterator s = { stack = collapseLHS [s]; started = false } - - let notStarted() = raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) - - let current i = - if i.started then - match i.stack with - | SetOne k :: _ -> k - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Set iterator, unexpected stack for current" - else - notStarted() - - let rec moveNext i = - if i.started then - match i.stack with - | SetOne _ :: rest -> - i.stack <- collapseLHS rest; - not i.stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" - else - i.started <- true; // The first call to MoveNext "starts" the enumeration. - not i.stack.IsEmpty - - let mkIEnumerator s = - let i = ref (mkIterator s) - { 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() = () } - - //-------------------------------------------------------------------------- - // Set comparison. This can be expensive. - //-------------------------------------------------------------------------- - - let rec compareStacks (comparer: IComparer<'T>) l1 l2 = - match l1,l2 with - | [],[] -> 0 - | [],_ -> -1 - | _,[] -> 1 - | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (SetEmpty :: t1) (n2r :: t2) - | (SetNode(n1k,(SetEmpty as emp),n1r,_) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) - | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) - | (SetOne(n1k) :: t1),_ -> - compareStacks comparer (SetEmpty :: SetOne(n1k) :: t1) l2 - | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> - compareStacks comparer (n1l :: SetNode(n1k,SetEmpty,n1r,0) :: t1) l2 - | _,(SetOne(n2k) :: t2) -> - compareStacks comparer l1 (SetEmpty :: SetOne(n2k) :: t2) - | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> - compareStacks comparer l1 (n2l :: SetNode(n2k,SetEmpty,n2r,0) :: t2) - - let compare comparer s1 s2 = - match s1,s2 with - | SetEmpty,SetEmpty -> 0 - | SetEmpty,_ -> -1 - | _,SetEmpty -> 1 - | _ -> compareStacks comparer [s1] [s2] - - let choose s = minimumElement s - - let toList s = - let rec loop m acc = - match m with - | SetNode(k,l,r,_) -> loop l (k :: loop r acc) - | SetOne(k) -> k ::acc - | SetEmpty -> acc - loop s [] - - let copyToArray s (arr: _[]) i = - let j = ref i - iter (fun x -> arr.[!j] <- x; j := !j + 1) s - - let toArray s = - let n = (count s) - let res = Array.zeroCreate n - copyToArray s res 0; - res - - - - let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = - if e.MoveNext() then + let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = + if e.MoveNext() then mkFromEnumerator comparer (add comparer e.Current acc) e - else acc - - let ofSeq comparer (c: IEnumerable<_>) = - use ie = c.GetEnumerator() - mkFromEnumerator comparer SetEmpty ie + else acc - let ofArray comparer l = Array.fold (fun acc k -> add comparer k acc) SetEmpty l + let ofSeq comparer (c: IEnumerable<_>) = + use ie = c.GetEnumerator() + mkFromEnumerator comparer SetEmpty ie + let ofArray comparer l = + Array.fold (fun acc k -> add comparer k acc) SetEmpty 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>) = #if !FX_NO_BINARY_SERIALIZATION - [] - // NOTE: This type is logically immutable. This field is only mutated during deserialization. - let mutable comparer = comparer - - [] - // NOTE: This type is logically immutable. This field is only mutated during deserialization. - let mutable tree = tree - - // NOTE: This type is logically immutable. This field is only mutated during serialization and deserialization. - // - // WARNING: The compiled name of this field may never be changed because it is part of the logical - // WARNING: permanent serialization format for this type. - let mutable serializedData = null + [] + // NOTE: This type is logically immutable. This field is only mutated during deserialization. + let mutable comparer = comparer + + [] + // NOTE: This type is logically immutable. This field is only mutated during deserialization. + let mutable tree = tree + + // NOTE: This type is logically immutable. This field is only mutated during serialization and deserialization. + // + // WARNING: The compiled name of this field may never be changed because it is part of the logical + // WARNING: permanent serialization format for this type. + let mutable serializedData = null #endif - // 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). + // 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> - Set<'T>(comparer, SetEmpty) + static let empty: Set<'T> = + let comparer = LanguagePrimitives.FastGenericComparer<'T> + Set<'T>(comparer, SetEmpty) #if !FX_NO_BINARY_SERIALIZATION - [] - member __.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = - ignore(context) - serializedData <- SetTree.toArray tree - - // Do not set this to null, since concurrent threads may also be serializing the data - //[] - //member __.OnSerialized(context: System.Runtime.Serialization.StreamingContext) = - // serializedData <- null - - [] - member __.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = - ignore(context) - comparer <- LanguagePrimitives.FastGenericComparer<'T> - tree <- SetTree.ofArray comparer serializedData - serializedData <- null + [] + member __.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = + ignore(context) + serializedData <- SetTree.toArray tree + + // Do not set this to null, since concurrent threads may also be serializing the data + //[] + //member __.OnSerialized(context: System.Runtime.Serialization.StreamingContext) = + // serializedData <- null + + [] + member __.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = + ignore(context) + comparer <- LanguagePrimitives.FastGenericComparer<'T> + tree <- SetTree.ofArray comparer serializedData + serializedData <- null #endif - [] - member internal set.Comparer = comparer + [] + member internal set.Comparer = comparer - member internal set.Tree: SetTree<'T> = tree + member internal set.Tree: SetTree<'T> = tree - [] - static member Empty: Set<'T> = empty + [] + 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.numAdds <- SetTree.numAdds + 1 - SetTree.totalSizeOnSetAdd <- SetTree.totalSizeOnSetAdd + float (SetTree.count s.Tree) + 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.numRemoves <- SetTree.numRemoves + 1 + SetTree.report() + SetTree.numRemoves <- SetTree.numRemoves + 1 #endif - Set<'T>(s.Comparer,SetTree.remove s.Comparer value s.Tree) + 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.numLookups <- SetTree.numLookups + 1 - SetTree.totalSizeOnSetLookup <- SetTree.totalSizeOnSetLookup + float (SetTree.count s.Tree) + 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 = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + SetTree.fold (fun x z -> f.Invoke(z, x)) z s.Tree + + [] + member s.IsEmpty = + SetTree.isEmpty s.Tree + + member s.Partition f : Set<'T> * Set<'T> = + match s.Tree with + | SetEmpty -> s, s + | _ -> 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> = + match s.Tree with + | SetEmpty -> s + | _ -> Set(s.Comparer, SetTree.filter s.Comparer f s.Tree) + + 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<_>.SetEmpty) s.Tree) + + member s.Exists f = + SetTree.exists f s.Tree + + member s.ForAll f = + SetTree.forall f s.Tree + + [] + static member (-) (set1: Set<'T>, set2: Set<'T>) = + match set1.Tree with + | SetEmpty -> set1 (* 0 - B = 0 *) + | _ -> + match set2.Tree with + | SetEmpty -> set1 (* A - 0 = A *) + | _ -> Set(set1.Comparer, SetTree.diff set1.Comparer set1.Tree set2.Tree) + + [] + static member (+) (set1: Set<'T>, set2: Set<'T>) = +#if TRACE_SETS_AND_MAPS + SetTree.report() + SetTree.numUnions <- SetTree.numUnions + 1 +#endif + match set2.Tree with + | SetEmpty -> set1 (* A U 0 = A *) + | _ -> + match set1.Tree with + | SetEmpty -> set2 (* 0 U B = B *) + | _ -> Set(set1.Comparer, SetTree.union set1.Comparer set1.Tree set2.Tree) - member s.Iterate(x) = SetTree.iter x s.Tree + static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = + match b.Tree with + | SetEmpty -> b (* A INTER 0 = 0 *) + | _ -> + match a.Tree with + | SetEmpty -> a (* 0 INTER B = 0 *) + | _ -> Set(a.Comparer, SetTree.intersection a.Comparer a.Tree b.Tree) - member s.Fold f z = - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) - SetTree.fold (fun x z -> f.Invoke(z, x)) z s.Tree + static member Union(sets:seq>) : Set<'T> = + Seq.fold (fun s1 s2 -> s1 + s2) Set<'T>.Empty sets - [] - member s.IsEmpty = SetTree.isEmpty s.Tree + static member Intersection(sets:seq>) : Set<'T> = + Seq.reduce (fun s1 s2 -> Set.Intersection(s1, s2)) sets - member s.Partition f : Set<'T> * Set<'T> = - match s.Tree with - | SetEmpty -> s,s - | _ -> let t1,t2 = SetTree.partition s.Comparer f s.Tree in Set(s.Comparer,t1), Set(s.Comparer,t2) + static member Equality(a: Set<'T>, b: Set<'T>) = + (SetTree.compare a.Comparer a.Tree b.Tree = 0) - member s.Filter f : Set<'T> = - match s.Tree with - | SetEmpty -> s - | _ -> Set(s.Comparer,SetTree.filter s.Comparer f s.Tree) + static member Compare(a: Set<'T>, b: Set<'T>) = + SetTree.compare a.Comparer a.Tree b.Tree - 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<_>.SetEmpty) s.Tree) + [] + member x.Choose = SetTree.choose x.Tree - member s.Exists f = SetTree.exists f s.Tree + [] + member x.MinimumElement = SetTree.minimumElement x.Tree - member s.ForAll f = SetTree.forall f s.Tree + [] + member x.MaximumElement = SetTree.maximumElement x.Tree - [] - static member (-) (set1: Set<'T>, set2: Set<'T>) = - match set1.Tree with - | SetEmpty -> set1 (* 0 - B = 0 *) - | _ -> - match set2.Tree with - | SetEmpty -> set1 (* A - 0 = A *) - | _ -> Set(set1.Comparer,SetTree.diff set1.Comparer set1.Tree set2.Tree) + member x.IsSubsetOf(otherSet: Set<'T>) = + SetTree.subset x.Comparer x.Tree otherSet.Tree - [] - static member (+) (set1: Set<'T>, set2: Set<'T>) = -#if TRACE_SETS_AND_MAPS - SetTree.report() - SetTree.numUnions <- SetTree.numUnions + 1 -#endif - match set2.Tree with - | SetEmpty -> set1 (* A U 0 = A *) - | _ -> - match set1.Tree with - | SetEmpty -> set2 (* 0 U B = B *) - | _ -> Set(set1.Comparer,SetTree.union set1.Comparer set1.Tree set2.Tree) - - static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = - match b.Tree with - | SetEmpty -> b (* A INTER 0 = 0 *) - | _ -> - match a.Tree with - | SetEmpty -> a (* 0 INTER B = 0 *) - | _ -> Set(a.Comparer,SetTree.intersection a.Comparer a.Tree b.Tree) - - 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> = - 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) - - static member Compare(a: Set<'T>, b: Set<'T>) = SetTree.compare a.Comparer a.Tree b.Tree - - [] - member x.Choose = SetTree.choose x.Tree - - [] - member x.MinimumElement = SetTree.minimumElement x.Tree - - [] - member x.MaximumElement = SetTree.maximumElement x.Tree - - member x.IsSubsetOf(otherSet: Set<'T>) = 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.psubset x.Comparer x.Tree otherSet.Tree - - member x.IsProperSupersetOf(otherSet: Set<'T>) = SetTree.psubset x.Comparer otherSet.Tree x.Tree - - member x.ToList () = SetTree.toList x.Tree - - member x.ToArray () = SetTree.toArray x.Tree - - 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) - abs res - - 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() - let m2 = e2.MoveNext() - (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 ICollection<'T> with - member s.Add(x) = ignore(x); 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.Contains(x) = SetTree.mem s.Comparer x s.Tree - member s.CopyTo(arr,i) = SetTree.copyToArray s.Tree arr i - member s.IsReadOnly = true - member s.Count = s.Count - - interface IReadOnlyCollection<'T> with - member s.Count = s.Count - - interface IEnumerable<'T> with - member s.GetEnumerator() = SetTree.mkIEnumerator s.Tree - - interface IEnumerable with - override s.GetEnumerator() = (SetTree.mkIEnumerator s.Tree :> IEnumerator) - - static member Singleton(x:'T) : Set<'T> = Set<'T>.Empty.Add(x) - - 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 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 - | [] -> "set []" - | [h1] -> System.Text.StringBuilder().Append("set [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("]").ToString() - | [h1;h2] -> System.Text.StringBuilder().Append("set [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h2).Append("]").ToString() - | [h1;h2;h3] -> System.Text.StringBuilder().Append("set [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h2).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h3).Append("]").ToString() - | h1 :: h2 :: h3 :: _ -> System.Text.StringBuilder().Append("set [").Append(LanguagePrimitives.anyToStringShowingNull h1).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h2).Append("; ").Append(LanguagePrimitives.anyToStringShowingNull h3).Append("; ... ]").ToString() - - and - [] - SetDebugView<'T when 'T : comparison>(v: Set<'T>) = - - [] - member x.Items = v |> Seq.truncate 1000 |> Seq.toArray + member x.IsSupersetOf(otherSet: Set<'T>) = + SetTree.subset x.Comparer otherSet.Tree x.Tree -namespace Microsoft.FSharp.Collections + member x.IsProperSubsetOf(otherSet: Set<'T>) = + 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.ToArray () = SetTree.toArray x.Tree + + 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) + abs res + + 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() + let m2 = e2.MoveNext() + (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 ICollection<'T> with + member s.Add(x) = ignore(x); 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.Contains(x) = SetTree.mem s.Comparer x s.Tree + + member s.CopyTo(arr, i) = SetTree.copyToArray s.Tree arr i + + member s.IsReadOnly = true + + member s.Count = s.Count + + interface IReadOnlyCollection<'T> with + member s.Count = s.Count + + interface IEnumerable<'T> with + member s.GetEnumerator() = SetTree.mkIEnumerator s.Tree + + interface IEnumerable with + override s.GetEnumerator() = (SetTree.mkIEnumerator s.Tree :> IEnumerator) + + static member Singleton(x:'T) : Set<'T> = Set<'T>.Empty.Add(x) + + 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 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 + | [] -> "set []" + | [h1] -> + let txt1 = LanguagePrimitives.anyToStringShowingNull h1 + StringBuilder().Append("set [").Append(txt1).Append("]").ToString() + | [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] -> + 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() + | 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>) = + + [] + member x.Items = v |> Seq.truncate 1000 |> Seq.toArray - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Collections +[] +[] +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.psubset 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.psubset 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/tests/scripts/codingConventions.fsx b/tests/scripts/codingConventions.fsx index 9f5a997e020..69097bb4b0f 100644 --- a/tests/scripts/codingConventions.fsx +++ b/tests/scripts/codingConventions.fsx @@ -3,7 +3,7 @@ open System.IO let lines = - [| for dir in [ "src/fsharp"; "src/fsharp/symbols"; "src/fsharp/service"; "src/absil" ]do + [| for dir in [ "src/fsharp"; "src/fsharp/FSharp.Core"; "src/fsharp/symbols"; "src/fsharp/service"; "src/absil" ]do for file in Directory.EnumerateFiles(__SOURCE_DIRECTORY__ + "/../../" + dir,"*.fs") do // TcGlobals.fs gets an exception let lines = File.ReadAllLines file