From c37d6654e25be60801353f0129219def2af03a25 Mon Sep 17 00:00:00 2001 From: Gustavo Guerra Date: Sat, 26 Oct 2013 18:32:10 +0100 Subject: [PATCH] Don't throw an exception when R not installed (fixes #48) --- src/RProvider/RProvider.fs | 207 ++++++++++++++++++++----------------- 1 file changed, 114 insertions(+), 93 deletions(-) diff --git a/src/RProvider/RProvider.fs b/src/RProvider/RProvider.fs index e46f5545..2a5a67b0 100644 --- a/src/RProvider/RProvider.fs +++ b/src/RProvider/RProvider.fs @@ -14,40 +14,50 @@ open RInterop open Microsoft.Win32 open System.IO -module internal ProviderUtils = +type private RLocation = +| RLocation of string +| RNotFound of string + +module private ProviderUtils = + // Have to be careful that this code is in its own module // If it is in some other module, which might be initialized before the PATH is set, we will get initialization exceptions let rLocation = + let locateRfromRegistry () = - let rCore = - match Registry.LocalMachine.OpenSubKey @"SOFTWARE\R-core", Registry.CurrentUser.OpenSubKey @"SOFTWARE\R-core" with - | null, null -> failwithf "Reg key Software\R-core does not exist; R is likely not installed on this computer" - | null, x -> x - | x, _ -> x - - let key = rCore.OpenSubKey "R" - if key = null then - failwith "SOFTWARE\R-core exists but subkey R does not exist" - key.GetValue "InstallPath" |> unbox + let getRLocationFromRCoreKey (rCore:RegistryKey) = + let key = rCore.OpenSubKey "R" + if key = null then + RNotFound "SOFTWARE\R-core exists but subkey R does not exist" + else + key.GetValue "InstallPath" |> unbox |> RLocation + + match Registry.LocalMachine.OpenSubKey @"SOFTWARE\R-core", Registry.CurrentUser.OpenSubKey @"SOFTWARE\R-core" with + | null, null -> RNotFound "Reg key Software\R-core does not exist; R is likely not installed on this computer" + | null, x -> getRLocationFromRCoreKey x + | x, _ -> getRLocationFromRCoreKey x match Environment.GetEnvironmentVariable "R_HOME" with | null -> locateRfromRegistry() - | rPath -> rPath - + | rPath -> RLocation rPath [] type public RProvider(cfg:TypeProviderConfig) as this = inherit TypeProviderForNamespaces() // R potentially may be not installed - handle this in static constructor for improved diag (G.B.) - static do - let binPath = Path.Combine(ProviderUtils.rLocation, "bin", if Environment.Is64BitProcess then "x64" else "i386") - if not (Path.Combine(binPath, "R.dll") |> File.Exists) then - failwithf "No R engine at %s" binPath - - // Set the path - Environment.SetEnvironmentVariable("PATH", Environment.GetEnvironmentVariable("PATH") + ";" + binPath) + static let initializationError = lazy ( + match ProviderUtils.rLocation with + | RNotFound errorMessage -> Some errorMessage + | RLocation rLocation -> + let binPath = Path.Combine(rLocation, "bin", if Environment.Is64BitProcess then "x64" else "i386") + if not (Path.Combine(binPath, "R.dll") |> File.Exists) then + Some <| sprintf "No R engine at %s" binPath + else + // Set the path + Environment.SetEnvironmentVariable("PATH", Environment.GetEnvironmentVariable("PATH") + ";" + binPath) + None) // Get the assembly and namespace used to house the provided types let asm = System.Reflection.Assembly.GetExecutingAssembly() @@ -55,79 +65,90 @@ type public RProvider(cfg:TypeProviderConfig) as this = // Expose all available packages as namespaces do - for package in getPackages() do - let pns = ns + "." + package - let pty = ProvidedTypeDefinition(asm, pns, "R", Some(typeof)) - - pty.AddXmlDocDelayed <| fun () -> getPackageDescription package - pty.AddMembersDelayed( fun () -> - [ loadPackage package - let bindings = getBindings package - - // We get the function descriptions for R the first time they are needed - let titles = lazy getFunctionDescriptions package - - for name, rval in Map.toSeq bindings do - let memberName = makeSafeName name - match rval with - | RValue.Function(paramList, hasVarArgs) -> - let paramList = [ for p in paramList -> - ProvidedParameter(makeSafeName p, typeof, optionalValue=null) - - if hasVarArgs then - yield ProvidedParameter("paramArray", typeof, optionalValue=null, isParamArray=true) - ] - - let paramCount = paramList.Length - - let pm = ProvidedMethod( - methodName = memberName, - parameters = paramList, - returnType = typeof, - IsStaticMethod = true, - InvokeCode = fun args -> if args.Length <> paramCount then - failwithf "Expected %d arguments and received %d" paramCount args.Length - - if hasVarArgs then - let namedArgs = - Array.sub (Array.ofList args) 0 (paramCount-1) - |> List.ofArray - let namedArgs = Quotations.Expr.NewArray(typeof, namedArgs) - let varArgs = args.[paramCount-1] - <@@ RInterop.call package name %%namedArgs %%varArgs @@> - else - let namedArgs = Quotations.Expr.NewArray(typeof, args) - <@@ RInterop.call package name %%namedArgs [||] @@> ) - - pm.AddXmlDocDelayed (fun () -> match titles.Value.TryFind name with - | Some docs -> docs - | None -> "No documentation available") - - yield pm :> MemberInfo - - // Yield an additional overload that takes a Dictionary - // This variant is more flexible for constructing lists, data frames etc. - let pdm = ProvidedMethod( - methodName = memberName, - parameters = [ ProvidedParameter("paramsByName", typeof>) ], - returnType = typeof, - IsStaticMethod = true, - InvokeCode = fun args -> if args.Length <> 1 then - failwithf "Expected 1 argument and received %d" args.Length - let argsByName = args.[0] - <@@ let vals = %%argsByName: IDictionary - let valSeq = vals :> seq> - RInterop.callFunc package name valSeq null @@> ) - yield pdm :> MemberInfo - | RValue.Value -> - yield ProvidedProperty( - propertyName = memberName, - propertyType = typeof, - IsStatic = true, - GetterCode = fun _ -> <@@ RInterop.call package name [| |] [| |] @@>) :> MemberInfo ] ) - - this.AddNamespace(pns, [ pty ]) - + match initializationError.Value with + | Some error -> + // add an error static property (shown when typing `R.`) + let pty = ProvidedTypeDefinition(asm, ns, "R", Some(typeof)) + let prop = ProvidedProperty("", typeof, IsStatic = true, GetterCode = fun _ -> <@@ error @@>) + prop.AddXmlDoc error + pty.AddMember prop + this.AddNamespace(ns, [ pty ]) + // add an error namespace (shown when typing `open RProvider.`) + this.AddNamespace(ns + ".Error: " + error, [ pty ]) + | None -> + for package in getPackages() do + let pns = ns + "." + package + let pty = ProvidedTypeDefinition(asm, pns, "R", Some(typeof)) + + pty.AddXmlDocDelayed <| fun () -> getPackageDescription package + pty.AddMembersDelayed( fun () -> + [ loadPackage package + let bindings = getBindings package + + // We get the function descriptions for R the first time they are needed + let titles = lazy getFunctionDescriptions package + + for name, rval in Map.toSeq bindings do + let memberName = makeSafeName name + match rval with + | RValue.Function(paramList, hasVarArgs) -> + let paramList = [ for p in paramList -> + ProvidedParameter(makeSafeName p, typeof, optionalValue=null) + + if hasVarArgs then + yield ProvidedParameter("paramArray", typeof, optionalValue=null, isParamArray=true) + ] + + let paramCount = paramList.Length + + let pm = ProvidedMethod( + methodName = memberName, + parameters = paramList, + returnType = typeof, + IsStaticMethod = true, + InvokeCode = fun args -> if args.Length <> paramCount then + failwithf "Expected %d arguments and received %d" paramCount args.Length + + if hasVarArgs then + let namedArgs = + Array.sub (Array.ofList args) 0 (paramCount-1) + |> List.ofArray + let namedArgs = Quotations.Expr.NewArray(typeof, namedArgs) + let varArgs = args.[paramCount-1] + <@@ RInterop.call package name %%namedArgs %%varArgs @@> + else + let namedArgs = Quotations.Expr.NewArray(typeof, args) + <@@ RInterop.call package name %%namedArgs [||] @@> ) + + pm.AddXmlDocDelayed (fun () -> match titles.Value.TryFind name with + | Some docs -> docs + | None -> "No documentation available") + + yield pm :> MemberInfo + + // Yield an additional overload that takes a Dictionary + // This variant is more flexible for constructing lists, data frames etc. + let pdm = ProvidedMethod( + methodName = memberName, + parameters = [ ProvidedParameter("paramsByName", typeof>) ], + returnType = typeof, + IsStaticMethod = true, + InvokeCode = fun args -> if args.Length <> 1 then + failwithf "Expected 1 argument and received %d" args.Length + let argsByName = args.[0] + <@@ let vals = %%argsByName: IDictionary + let valSeq = vals :> seq> + RInterop.callFunc package name valSeq null @@> ) + yield pdm :> MemberInfo + | RValue.Value -> + yield ProvidedProperty( + propertyName = memberName, + propertyType = typeof, + IsStatic = true, + GetterCode = fun _ -> <@@ RInterop.call package name [| |] [| |] @@>) :> MemberInfo ] ) + + this.AddNamespace(pns, [ pty ]) + [] do() \ No newline at end of file