direct-plugins 1.0 → 1.1

raw patch · 2 files changed

+192/−8 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• System/Plugins.hs +187/−4
• direct-plugins.cabal +5/−4

@@ -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

@@ -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