Add dynCompileExpr

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5fcfd1d..5e75793 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -78,7 +78,7 @@ module GHC (
        RunResult(..),
        runStmt,
        showModule,
-       compileExpr, HValue,
+       compileExpr, HValue, dynCompileExpr,
        lookupName,
 #endif
 
@@ -175,6 +175,7 @@ module GHC (
 
 #ifdef GHCI
 import qualified Linker
+import Data.Dynamic     ( Dynamic )
 import Linker          ( HValue, extendLinkEnv )
 import TcRnDriver      ( tcRnLookupRdrName, tcRnGetInfo,
                          tcRnLookupName, getModuleExports )
@@ -226,10 +227,11 @@ import Finder
 import HscMain         ( newHscEnv, hscFileCheck, HscChecked(..) )
 import HscTypes
 import DynFlags
-import SysTools                ( initSysTools, cleanTempFiles, cleanTempFilesExcept )
+import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
+                      cleanTempDirs )
 import Module
 import UniqFM
-import PackageConfig    ( PackageId )
+import PackageConfig    ( PackageId, stringToPackageId )
 import FiniteMap
 import Panic
 import Digraph
@@ -309,13 +311,15 @@ defaultErrorHandler dflags inner =
 -- handling, but still get the ordinary cleanup behaviour.
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
-   -- make sure we clean up after ourselves
-   later (unless (dopt Opt_KeepTmpFiles dflags) $ 
-           cleanTempFiles dflags) 
-       -- exceptions will be blocked while we clean the temporary files,
-       -- so there shouldn't be any difficulty if we receive further
-       -- signals.
-   inner
+    -- make sure we clean up after ourselves
+    later (unless (dopt Opt_KeepTmpFiles dflags) $
+               do cleanTempFiles dflags
+                  cleanTempDirs dflags
+          )
+          -- exceptions will be blocked while we clean the temporary files,
+          -- so there shouldn't be any difficulty if we receive further
+          -- signals.
+    inner
 
 
 -- | Initialises GHC.  This must be done /once/ only.  Takes the
@@ -1628,7 +1632,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time))
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
+  = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
                                
 noHsFileErr loc path
   = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
@@ -1846,8 +1850,10 @@ findModule' hsc_env mod_name maybe_pkg =
          res <- findImportedModule hsc_env mod_name Nothing
          case res of
            Found _ m | modulePackageId m /= this_pkg -> return m
-                        -- not allowed to be a home module
-           err -> let msg = cantFindError dflags mod_name err in
+                     | otherwise -> throwDyn (CmdLineError (showSDoc $
+                                       text "module" <+> pprModule m <+>
+                                       text "is not loaded"))
+           err -> let msg = cannotFindModule dflags mod_name err in
                   throwDyn (CmdLineError (showSDoc msg))
 
 #ifdef GHCI
@@ -2016,6 +2022,27 @@ compileExpr s expr = withSession s $ \hsc_env -> do
                  _          -> panic "compileExpr"
 
 -- -----------------------------------------------------------------------------
+-- Compile an expression into a dynamic
+
+dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
+dynCompileExpr ses expr = do
+    (full,exports) <- getContext ses
+    setContext ses full $
+        (mkModule
+            (stringToPackageId "base") (mkModuleName "Data.Dynamic")
+        ):exports
+    let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
+    res <- withSession ses (flip hscStmt stmt)
+    setContext ses full exports
+    case res of
+        Nothing -> return Nothing
+        Just (_, names, hvals) -> do
+            vals <- (unsafeCoerce# hvals :: IO [Dynamic])
+            case (names,vals) of
+                (_:[], v:[])    -> return (Just v)
+                _               -> panic "dynCompileExpr"
+
+-- -----------------------------------------------------------------------------
 -- running a statement interactively
 
 data RunResult