#light namespace Microsoft.FSharp.Compiler open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators open Microsoft.FSharp.Text open Microsoft.FSharp.Collections open Microsoft.FSharp.Reflection open System.Globalization open System.IO open System.Text open System.Reflection module SR = let private resources = lazy (new System.Resources.ResourceManager("fsstrings", System.Reflection.Assembly.GetExecutingAssembly())) let GetString(name:string) = let s = resources.Force().GetString(name, System.Globalization.CultureInfo.CurrentUICulture) #if DEBUG if null = s then System.Diagnostics.Debug.Assert(false, sprintf "**RESOURCE ERROR**: Resource token %s does not exist!" name) #endif s let GetObject(name:string) = let o = resources.Force().GetObject(name, System.Globalization.CultureInfo.CurrentUICulture) #if DEBUG if null = o then System.Diagnostics.Debug.Assert(false, sprintf "**RESOURCE ERROR**: Resource token %s does not exist!" name) #endif o module DiagnosticMessage = open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Reflection open System.Reflection open Internal.Utilities.StructuredFormat let staticInvokeFlags = BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Static let mkFunctionValue (tys: System.Type[]) (impl:obj->obj) = FSharpValue.MakeFunction(FSharpType.MakeFunctionType(tys.[0],tys.[1]), impl) let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition() let mkFunTy a b = funTyC.MakeGenericType([| a;b |]) let isNamedType(ty:System.Type) = not (ty.IsArray || ty.IsByRef || ty.IsPointer) let isFunctionType (ty1:System.Type) = isNamedType(ty1) && ty1.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(funTyC) let rec destFunTy (ty:System.Type) = if isFunctionType ty then ty, ty.GetGenericArguments() else match ty.BaseType with | null -> failwith "destFunTy: not a function type" | b -> destFunTy b let buildFunctionForOneArgPat (ty: System.Type) impl = let _,tys = destFunTy ty let dty = tys.[0] let rty = tys.[1] // PERF: this technique is a bit slow (e.g. in simple cases, like 'sprintf "%x"') mkFunctionValue tys (fun inp -> impl rty inp) let capture1 (fmt:string) i args ty (go : obj list -> System.Type -> int -> obj) : obj = match fmt.[i] with | '%' -> go args ty (i+1) | 'd' | 'f' | 's' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1)) | _ -> failwith "bad format specifier" // newlines and tabs get converted to strings when read from a resource file // this will preserve their original intention let postProcessString (s : string) = s.Replace("\\n","\n").Replace("\\t","\t") let createMessageString (messageString : string) (fmt : Printf.StringFormat<'T>) : 'T = let fmt = fmt.Value // here, we use the actual error string, as opposed to the one stored as fmt let len = fmt.Length /// Function to capture the arguments and then run. let rec capture args ty i = if i >= len || (fmt.[i] = '%' && i+1 >= len) then let b = new System.Text.StringBuilder() b.AppendFormat(messageString, (Array.of_list (List.rev args))) |> ignore box(b.ToString()) // REVIEW: For these purposes, this should be a nop, but I'm leaving it // in incase we ever decide to support labels for the error format string // E.g., "%s%d" elif System.Char.IsSurrogatePair(fmt,i) then capture args ty (i+2) else match fmt.[i] with | '%' -> let i = i+1 capture1 fmt i args ty capture | c -> capture args ty (i+1) (unbox (capture [] (typeof<'T>) 0) : 'T) type ResourceString<'T>(fmtString : string, fmt : Printf.StringFormat<'T>) = member a.Format = createMessageString fmtString fmt let DeclareResourceString ((messageID : string),(fmt : Printf.StringFormat<'T>)) = let mutable messageString = SR.GetString(messageID) #if DEBUG // validate that the message string exists let fmtString = fmt.Value if null = messageString then System.Diagnostics.Debug.Assert(false, sprintf "**DECLARED MESSAGE ERROR** String resource %s does not exist" messageID) messageString <- "" // validate the formatting specifiers let countFormatHoles (s : string) = // remove escaped format holes let s = s.Replace("{{","").Replace("}}","") let len = s.Length - 2 let mutable pos = 0 let mutable nHoles = 0 let mutable order = Set.empty while pos < len do if s.[pos] = '{' then let mutable pos' = pos+1 while System.Char.IsNumber(s.[pos']) do pos' <- pos' + 1 if pos' > pos+1 && s.[pos'] = '}' then nHoles <- nHoles + 1 let ordern = (int) (s.[(pos+1) .. (pos'-1)]) order <- order.Add(ordern) pos <- pos' pos <- pos + 1 // the sort should be unnecessary, but better safe than sorry nHoles,Set.to_list order |> List.sort |> List.rev let countFormatPlaceholders (s : string) = // strip any escaped % characters - yes, this will fail if given %%%... let s = s.Replace("%%","") if s = "" then 0 else let len = s.Length - 1 let mutable pos = 0 let mutable nFmt = 0 while pos < len do if s.[pos] = '%' && (s.[pos+1] = 'd' || s.[pos+1] = 's' || s.[pos+1] = 'f') then nFmt <- nFmt + 1 pos <- pos + 2 ; else pos <- pos + 1 ; nFmt let nHoles,holes = countFormatHoles messageString let nPlaceholders = countFormatPlaceholders fmtString // first, verify that the number of holes in the message string does not exceed the // largest hole reference if holes <> [] && holes.[0] > nHoles - 1 then System.Diagnostics.Debug.Assert(false, sprintf "**DECLARED MESSAGE ERROR** Message string %s contains %d holes, but references hole %d" messageID nHoles holes.[0]) // next, verify that the number of format placeholders is the same as the number of holes if nHoles <> nPlaceholders then System.Diagnostics.Debug.Assert(false, sprintf "**DECLARED MESSAGE ERROR** Message string %s contains %d holes, but its format specifier contains %d placeholders" messageID nHoles nPlaceholders) #endif messageString <- postProcessString messageString new ResourceString<'T>(messageString, fmt)