diff --git a/System/Plugins.hs b/System/Plugins.hs --- a/System/Plugins.hs +++ b/System/Plugins.hs @@ -1,5 +1,15 @@ -module System.Plugins (load) where +-- | The recommended interface, because it is safer (guaranteed not to crash as long +-- as modules have not been mis-installed somehow), is 'loadDynamic'. For +-- versatility's sake, 'unsafeLoad' is provided as well, but caveat codor! +module System.Plugins (unsafeLoad, loadDynamic) where +import Data.Dynamic +import Data.IORef +import Data.List +import Data.Maybe +import Data.Typeable +import Unsafe.Coerce + import qualified BasicTypes import qualified DynFlags import qualified Encoding @@ -8,20 +18,59 @@ import qualified GHC import qualified GHC.Exts import qualified GHC.Paths (libdir) +import qualified HscTypes +import qualified IfaceSyn +import qualified IfaceType +import qualified IOEnv import qualified Linker +import qualified LoadIface +import qualified Maybes import qualified Module import MonadUtils (liftIO) import qualified Name import qualified ObjLink import qualified OccName +import qualified Outputable +import qualified PackageConfig import qualified Packages +import qualified TcRnTypes import qualified SrcLoc +import qualified UniqSupply import qualified Unique -import Unsafe.Coerce -load :: (String, String, String) -> IO (Maybe a) -load symbol@(packageName, moduleName, symbolName) +-- | Resolves the specified symbol to any given type. This means linking the package +-- containing it if it is not already linked, extracting the value of that symbol, +-- and returning that value. Because a call is made to 'unsafeCoerce', the behavior +-- is unpredictable (most likely an immediate crash) if the symbol is not actually of +-- the expected type. Because 'load' has no a priori way to know the type, you must +-- be certain to provide adequate type information in the caller, ie by giving a +-- type signature. +-- +-- Three error conditions are detected and handled nicely, returning +-- 'Nothing': The package does not exist; the package does not contain the given +-- module; or the module does not contain a symbol by the given name. +-- +-- As a limitation which may be relaxed in a future version, note that re-exports +-- are not chased; thus for example it is not possible to find the symbol +-- @base:Prelude.sum@, because that symbol is actually defined in @base:Data.List@. +unsafeLoad + :: (String, String, String) + -- ^ A tuple (@packageName@, @moduleName@, @symbolName@), specifying a symbol in + -- a package installed somewhere in ghc's database. + -- + -- @packageName@ is a full package name including a version, + -- ie @\"hello-1.0\"@; you can inspect these package names through + -- @ghc-pkg@. + -- + -- @moduleName@ is a fully-qualified module name, ie @\"Hello\"@ or + -- @\"Data.Dynamic\"@. + -- + -- @symbolName@ is an unqualified symbol name, ie @\"hello\"@. + -> IO (Maybe a) + -- ^ If the specified symbol is found, 'Just' its + -- value. Otherwise, 'Nothing'. +unsafeLoad symbol@(packageName, moduleName, symbolName) = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do GHC.runGhc (Just GHC.Paths.libdir) $ do flags <- GHC.getSessionDynFlags @@ -61,6 +110,133 @@ return $ Just $ unsafeCoerce result)) +-- | Resolves the specified symbol to a Dynamic. This means first parsing the installed +-- .hi file for the package containing the symbol to verify that the symbol is in fact +-- a Dynamic, then, if it is, linking the package if it is not already linked, +-- extracting the value of that symbol, and returning that value. Unlike 'load', this +-- function should be \"perfectly safe\", not crashing even if the symbol is not +-- actually of the expected type. +-- +-- Four error conditions are detected and handled nicely, returning +-- 'Nothing': The package does not exist; the package does not contain the given +-- module; the module does not contain a symbol by the given name; or the symbol's type +-- is not 'Dynamic'. +-- +-- As a limitation which may be relaxed in a future version, note that re-exports are +-- not chased; thus for example it is not possible to find the symbol +-- @base:Prelude.sum@, because that symbol is actually defined in @base:Data.List@. +-- (Also because that symbol is not a 'Dynamic'.) +loadDynamic + :: (String, String, String) + -- ^ A tuple (@packageName@, @moduleName@, @symbolName@), specifying a symbol in + -- a package installed somewhere in ghc's database. + -- + -- @packageName@ is a full package name including a version, + -- ie @\"hello-1.0\"@; you can inspect these package names through + -- @ghc-pkg@. + -- + -- @moduleName@ is a fully-qualified module name, ie @\"Hello\"@ or + -- @\"Data.Dynamic\"@. + -- + -- @symbolName@ is an unqualified symbol name, ie @\"hello\"@. + -> IO (Maybe Dynamic) + -- ^ If the specified symbol is found and of an appropriate type, 'Just' its + -- value. Otherwise, 'Nothing'. +loadDynamic symbol = do + maybeInterfaceType <- symbolInterfaceType symbol + case maybeInterfaceType of + Nothing -> return Nothing + Just interfaceType -> do + let isDynamic = interfaceTypeIsDynamic interfaceType + case isDynamic of + False -> return Nothing + True -> unsafeLoad symbol + + +symbolInterfaceType :: (String, String, String) -> IO (Maybe IfaceType.IfaceType) +symbolInterfaceType (packageName, moduleName, symbolName) + = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do + GHC.runGhc (Just GHC.Paths.libdir) $ do + flags <- GHC.getSessionDynFlags + GHC.setSessionDynFlags flags + + (flags, _) <- liftIO $ Packages.initPackages flags + + uniqueSupply <- liftIO $ UniqSupply.mkSplitUniqSupply 'a' + uniqueSupplyIORef <- liftIO $ newIORef uniqueSupply + hscEnv <- GHC.getSession + let packageState = DynFlags.pkgState flags + packageId = Module.fsToPackageId (FastString.mkFastString packageName) + case Packages.lookupPackage (Packages.pkgIdMap packageState) packageId of + Nothing -> do + liftIO $ putStrLn $ "Unknown package " ++ packageName ++ "." + return Nothing + Just packageConfig -> do + let installedPackageInfo + = PackageConfig.packageConfigToInstalledPackageInfo packageConfig + module' = Module.mkModule packageId $ Module.mkModuleName moduleName + libraryDirs = PackageConfig.libraryDirs installedPackageInfo + interfacePathWithinLibraryDir = moduleNameToInterfacePath moduleName + visitLibraryDir (libraryDir : moreLibraryDirs) = (do + let interfacePath = libraryDir ++ "/" ++ interfacePathWithinLibraryDir + environment = TcRnTypes.Env { + TcRnTypes.env_top = hscEnv, + TcRnTypes.env_us = uniqueSupplyIORef, + TcRnTypes.env_gbl = (), + TcRnTypes.env_lcl = () + } + errorOrModuleInterface + <- liftIO $ IOEnv.runIOEnv environment + $ LoadIface.readIface module' interfacePath False + case errorOrModuleInterface of + Maybes.Failed message -> visitLibraryDir moreLibraryDirs + Maybes.Succeeded moduleInterface -> do + let variableName = OccName.mkVarOcc symbolName + declarations = HscTypes.mi_decls moduleInterface + visitDeclaration ((_, declaration) : moreDeclarations) = (do + case declaration of + IfaceSyn.IfaceId { } -> do + if IfaceSyn.ifName declaration == variableName + then return $ Just $ IfaceSyn.ifType declaration + else visitDeclaration moreDeclarations + _ -> visitDeclaration moreDeclarations) + visitDeclaration [] = do + liftIO $ putStrLn $ "Unknown symbol " ++ symbolName + ++ " in module " ++ moduleName + ++ " in package " ++ packageName + ++ "." + return Nothing + visitDeclaration declarations) + visitLibraryDir [] = do + liftIO $ putStrLn $ "Unknown module " ++ moduleName + ++ " in package " ++ packageName + ++ "." + return Nothing + visitLibraryDir libraryDirs + + +interfaceTypeToString :: IfaceType.IfaceType -> String +interfaceTypeToString ifaceType + = Outputable.showSDoc $ IfaceType.pprIfaceType ifaceType + + +interfaceTypeIsDynamic :: IfaceType.IfaceType -> Bool +interfaceTypeIsDynamic (IfaceType.IfaceTyConApp constructor arguments) + = let interfaceTypeConstructorIsDynamic (IfaceType.IfaceTc name) + = let occName = Name.nameOccName name + typeName = OccName.occNameString occName + module' = Name.nameModule name + packageId = Module.modulePackageId module' + packageName = Module.packageIdString packageId + moduleName = Module.moduleNameString $ Module.moduleName module' + in (packageName == "base") + && (moduleName == "Data.Dynamic") + && (typeName == "Dynamic") + interfaceTypeConstructorIsDynamic _ = False + in (length arguments == 0) && (interfaceTypeConstructorIsDynamic constructor) +interfaceTypeIsDynamic _ = False + + encodeSymbol :: (String, String, String) -> String encodeSymbol (packageName, moduleName, symbolName) = (Encoding.zEncodeString packageName) @@ -69,6 +245,13 @@ ++ "_" ++ (Encoding.zEncodeString symbolName) ++ "_closure" + + +moduleNameToInterfacePath :: String -> String +moduleNameToInterfacePath moduleName = + let translateCharacter '.' = '/' + translateCharacter c = c + in (map translateCharacter moduleName) ++ ".hi" hasPrefix :: String -> String -> Bool diff --git a/direct-plugins.cabal b/direct-plugins.cabal --- a/direct-plugins.cabal +++ b/direct-plugins.cabal @@ -1,5 +1,5 @@ name: direct-plugins -version: 1.0 +version: 1.1 cabal-version: >= 1.2 build-type: Simple license: BSD3 @@ -7,14 +7,15 @@ copyright: Copyright (c) 2009 Dan Knapp author: Dan Knapp maintainer: dankna@gmail.com -homepage: http://www.dankna.com/software/ -bug-reports: http://www.dankna.com/issues/create/ +homepage: http://dankna.com/software/ +bug-reports: http://dankna.com/issues/create/ category: System synopsis: Lightweight replacement for Plugins, specific to GHC description: The Plugins package unfortunately does not work on GHC 6.12, and is at any rate rather poorly documented. This package uses the same general strategy but without - quite as many options, aiming to be simple and useful rather than complete. + quite as many options, aiming to be simple and useful rather than complete. This + release renames load to unsafeLoad and adds loadDynamic, which is type-safe. Library exposed-modules: System.Plugins