module System.Plugin (
pdynload
) where
import Control.Exception
import Control.Monad (when, liftM)
import Data.IORef
import Data.List (partition)
import GHC.Paths (libdir, ghc)
import MonadUtils (liftIO)
import System.Directory
import System.FilePath
import System.Exit
import System.IO
import System.Process
import System.Time
import Unsafe.Coerce
import qualified DynFlags
import qualified Exception
import qualified GHC
import qualified HscTypes
import qualified IOEnv
import qualified Linker
import qualified LoadIface
import qualified Maybes
import qualified Module
import qualified Name
import qualified OccName
import qualified Outputable
import qualified PackageConfig
import qualified Packages
import qualified SrcLoc
import qualified TcRnTypes
import qualified UniqSupply
import qualified Unique
data TypeCheckStatus = TypeMatch
| TypeMismatch String
deriving (Show, Eq, Ord)
pdynload :: (String, String)
-> (String, String)
-> IO (Maybe a)
pdynload (symbolModule, symbol) (typModule, typ) = do
putStr "* Check type ... "
status <- typeCheck (symbolModule, symbol) (typModule, typ)
case status of
TypeMismatch error -> do
putStrLn "failed : "
putStrLn error
return Nothing
TypeMatch -> do
putStrLn "done."
GHC.defaultErrorHandler DynFlags.defaultDynFlags $
GHC.runGhc (Just libdir) $ do
flags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags flags
(flags, _) <- liftIO $ Packages.initPackages flags
liftIO $ Linker.initDynLinker flags
pName <- liftIO $ do
putStrLn $ "* Lookup package of module " ++ symbolModule
lookupPackageName flags symbolModule
case pName of
Just pn ->
do
let pId = Module.stringToPackageId pn
hscEnv <- GHC.getSession
name <- liftIO $ parseSymbol (pn, symbolModule, symbol) hscEnv flags
case name of
Just n -> load n pId flags
Nothing -> return Nothing
Nothing -> return Nothing
typeCheck :: (String, String)
-> (String, String)
-> IO TypeCheckStatus
typeCheck (symbolModule, symbol) (typModule, typ) = do
uniqueId <- getPicoseconds
tempDir <- getTemporaryDirectory
let tempModule = "TypeCheck" ++ show uniqueId
tempFile = tempDir </> tempModule ++ ".hs"
errFile = tempDir </> tempModule ++ ".log"
checkExpression = "typecheck"
result <- bracket (openFile errFile WriteMode) hClose $ \errHandle -> do
let sourceCode =
"module " ++ tempModule ++ " where" ++ "\n"
++ "import qualified " ++ symbolModule ++ "\n"
++ (if null typModule
then "import Prelude\n"
else "import " ++ typModule ++ "\n")
++ checkExpression ++ " = " ++ (symbolModule ++ "." ++ symbol)
++ " :: " ++ typ
handle <- openFile tempFile WriteMode
hWrite handle sourceCode
let ghcOpts = ["-e", checkExpression, tempFile]
ghcProc <- runProcess ghc ghcOpts (Just tempDir) Nothing Nothing Nothing (Just errHandle)
waitForProcess ghcProc
status <- if result == ExitSuccess
then return TypeMatch
else liftM TypeMismatch $ readFile errFile
tryRemoveFile tempFile
tryRemoveFile errFile
return status
load :: (GHC.GhcMonad m)
=> (String, String, String)
-> Module.PackageId
-> GHC.DynFlags
-> m (Maybe a)
load (packageName, moduleName, symbolName) packageId flags =
Exception.ghandle
(\(GHC.CmdLineError _) -> do
liftIO $ putStrLn $ "Unknown package " ++ packageName
return Nothing)
(do
liftIO $ Linker.linkPackages flags [packageId]
Exception.ghandle
(\(GHC.ProgramError string) -> do
if hasPrefix string "Failed to load interface "
then liftIO $ putStrLn $ "Unknown module '" ++ moduleName ++ "'"
++ " in package '" ++ packageName ++ "'"
else liftIO $ putStrLn $ "Unknown symbol '" ++ symbolName ++ "'"
++ " in module '" ++ moduleName ++ "'"
++ " in package '" ++ packageName ++ "'"
return Nothing)
(do
liftIO $ putStrLn $ "* Linking " ++ packageName ++ ":" ++ moduleName ++ "." ++ symbolName ++ " ..."
session <- GHC.getSession
let name = Name.mkExternalName
(Unique.mkBuiltinUnique 0)
(Module.mkModule packageId
(Module.mkModuleName moduleName))
(OccName.mkVarOcc symbolName)
SrcLoc.noSrcSpan
result <- liftIO $ Linker.getHValue session name
return $ Just $ unsafeCoerce result))
lookupPackageName :: DynFlags.DynFlags -> String -> IO (Maybe String)
lookupPackageName flags moduleName
| packageNum == 0
= do
putStrLn $ "Can't found module " ++ show moduleName
return Nothing
| packageNum == 1
= do
let (packageConfig, isExpose) = head packages
pName = packageConfigIdString packageConfig
if isExpose
then return $ Just pName
else do
putStrLn $ "Module " ++ show moduleName ++ " hide in package " ++ pName
return Nothing
| null exposePackages
= do
putStrLn $ "Can't found module " ++ show moduleName
return Nothing
| otherwise
= do
let firstPackageIdString = packageConfigIdString $ fst $ head exposePackages
putStrLn $ "Module " ++ show moduleName ++ " expose in multiple packages :"
++ concatMap (\ (packageConfig, _) ->
"\n " ++ packageConfigIdString packageConfig) exposePackages
putStrLn $ "# Use package '" ++ firstPackageIdString ++ "' (Maybe you need specify package name)"
return $ Just firstPackageIdString
where packages
= Packages.lookupModuleInAllPackages flags (Module.mkModuleName moduleName)
packageNum
= length packages
exposePackages
= filter snd packages
parseSymbol :: (String, String, String)
-> HscTypes.HscEnv
-> GHC.DynFlags
-> IO (Maybe (String, String, String))
parseSymbol (packageName, moduleName, symbolName) hscEnv flags = do
putStrLn $ "* Parse " ++ packageName ++ ":" ++ moduleName ++ "." ++ symbolName ++ " ..."
uniqueSupply <- UniqSupply.mkSplitUniqSupply 'a'
uniqueSupplyIORef <- newIORef uniqueSupply
let packageId = Module.stringToPackageId packageName
module' = Module.mkModule packageId $ Module.mkModuleName moduleName
environment = TcRnTypes.Env {
TcRnTypes.env_top = hscEnv,
TcRnTypes.env_us = uniqueSupplyIORef,
TcRnTypes.env_gbl = (),
TcRnTypes.env_lcl = ()}
iface <- IOEnv.runIOEnv environment
$ LoadIface.findAndReadIface Outputable.empty module' False
case iface of
Maybes.Failed _ -> do
putStrLn $ "Can't found interface file of " ++ packageName ++ ":" ++ moduleName ++ "." ++ symbolName
return Nothing
Maybes.Succeeded (moduleInterface, hiFile) -> do
putStrLn $ "Scan interface file " ++ hiFile ++ " ..."
let ifaceExport = HscTypes.mi_exports moduleInterface
exports = map (\ (mod, items) ->
(Module.moduleNameString $ Module.moduleName mod
,concatMap (\item ->
case item of
HscTypes.Avail name -> [OccName.occNameString name]
HscTypes.AvailTC _ list ->
map OccName.occNameString list
) items)
) ifaceExport
(currentExports, otherExports) = partition (\ (mName, _) -> mName == moduleName) exports
case findSymbolInExportList currentExports symbolName of
Just _ -> do
putStrLn $ "'" ++ symbolName ++ "' defined in " ++ packageName ++ ":" ++ moduleName
return $ Just (packageName, moduleName, symbolName)
Nothing ->
case findSymbolInExportList otherExports symbolName of
Just mn -> do
putStrLn $ "'" ++ symbolName ++ "' is re-export from module " ++ mn
newPackageName <- do
putStrLn $ "* Lookup package of module " ++ mn
lookupPackageName flags mn
case newPackageName of
Just npn -> parseSymbol (npn, mn, symbolName) hscEnv flags
Nothing -> return Nothing
Nothing -> do
putStrLn $ "Can't found symbol " ++ symbolName ++ " in " ++ hiFile
return Nothing
packageConfigIdString :: Packages.PackageConfig -> String
packageConfigIdString = Module.packageIdString . PackageConfig.packageConfigId
hasPrefix :: String -> String -> Bool
hasPrefix string prefix =
take (length prefix) string == prefix
findSymbolInExportList :: Eq b => [(a, [b])] -> b -> Maybe a
findSymbolInExportList [] _ = Nothing
findSymbolInExportList ((moduleName, symList) :xs) sym
| sym `elem` symList
= Just moduleName
| otherwise
= findSymbolInExportList xs sym
getPicoseconds :: IO Integer
getPicoseconds = do
(TOD second picosecond) <- getClockTime
return (second * (10 ^ 12) + picosecond)
hWrite :: Handle -> String -> IO ()
hWrite hdl src =
hPutStr hdl src >> hClose hdl >> return ()
tryRemoveFile :: FilePath -> IO ()
tryRemoveFile filepath = do
isExist <- doesFileExist filepath
when isExist $ removeFile filepath