Add parseExpr and compileParsedExpr and use them in GHC API and GHCi

Summary:
This commit brings following changes and fixes:

 * Implement parseExpr and compileParsedExpr;
 * Fix compileExpr and dynCompilerExpr, which returned `()` for empty expr;
 * Fix :def and :cmd, which didn't work if `IO` or `String` is not in scope;
 * Use GHCiMonad instead IO in :def and :cmd;
 * Clean PrelInfo: delete dead comment and duplicate entries, add assertion.

See new tests for more details.

Test Plan: ./validate

Reviewers: austin, dterei, simonmar

Reviewed By: simonmar

Subscribers: thomie, bgamari

Differential Revision: https://phabricator.haskell.org/D974

GHC Trac Issues: #10508

3 files changed, 88 insertions, 65 deletions

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 39af5fa984..1a7d4ef71e 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -99,7 +99,7 @@ module GHC (
         -- ** Get/set the current context
         parseImportDecl,
         setContext, getContext,
-        setGHCiMonad,
+        setGHCiMonad, getGHCiMonad,
 #endif
         -- ** Inspecting the current context
         getBindings, getInsts, getPrintUnqual,
@@ -124,7 +124,8 @@ module GHC (
         lookupName,
 #ifdef GHCI
         -- ** Compiling expressions
-        InteractiveEval.compileExpr, HValue, dynCompileExpr,
+        HValue, parseExpr, compileParsedExpr,
+        InteractiveEval.compileExpr, dynCompileExpr,
 
         -- ** Other
         runTcInteractive,   -- Desired by some clients (Trac #8878)
@@ -1457,6 +1458,10 @@ setGHCiMonad name = withSession $ \hsc_env -> do
         let ic = (hsc_IC s) { ic_monad = ty }
         in s { hsc_IC = ic }
 
+-- | Get the monad GHCi lifts user statements into.
+getGHCiMonad :: GhcMonad m => m Name
+getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
+
 getHistorySpan :: GhcMonad m => History -> m SrcSpan
 getHistorySpan h = withSession $ \hsc_env ->
     return $ InteractiveEval.getHistorySpan hsc_env h
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 2ac2041502..2708396ec1 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -68,9 +68,10 @@ module HscMain
     , hscGetModuleInterface
     , hscRnImportDecls
     , hscTcRnLookupRdrName
-    , hscStmt, hscStmtWithLocation
+    , hscStmt, hscStmtWithLocation, hscParsedStmt
     , hscDecls, hscDeclsWithLocation
     , hscTcExpr, hscImport, hscKcType
+    , hscParseExpr
     , hscCompileCoreExpr
     -- * Low-level exports for hooks
     , hscCompileCoreExpr'
@@ -1409,30 +1410,36 @@ hscStmtWithLocation :: HscEnv
                     -> Int    -- ^ Starting line
                     -> IO (Maybe ([Id], IO [HValue], FixityEnv))
 hscStmtWithLocation hsc_env0 stmt source linenumber =
- runInteractiveHsc hsc_env0 $ do
+  runInteractiveHsc hsc_env0 $ do
     maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
     case maybe_stmt of
-        Nothing -> return Nothing
-
-        Just parsed_stmt -> do
-            -- Rename and typecheck it
-            hsc_env <- getHscEnv
-            (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt
-
-            -- Desugar it
-            ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
-            liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
-            handleWarnings
+      Nothing -> return Nothing
 
-            -- Then code-gen, and link it
-            -- It's important NOT to have package 'interactive' as thisPackageKey
-            -- for linking, else we try to link 'main' and can't find it.
-            -- Whereas the linker already knows to ignore 'interactive'
-            let  src_span     = srcLocSpan interactiveSrcLoc
-            hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
-            let hval_io = unsafeCoerce# hval :: IO [HValue]
-
-            return $ Just (ids, hval_io, fix_env)
+      Just parsed_stmt -> do
+        hsc_env <- getHscEnv
+        liftIO $ hscParsedStmt hsc_env parsed_stmt
+
+hscParsedStmt :: HscEnv
+              -> GhciLStmt RdrName  -- ^ The parsed statement
+              -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
+  -- Rename and typecheck it
+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
+
+  -- Desugar it
+  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
+  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
+  handleWarnings
+
+  -- Then code-gen, and link it
+  -- It's important NOT to have package 'interactive' as thisPackageKey
+  -- for linking, else we try to link 'main' and can't find it.
+  -- Whereas the linker already knows to ignore 'interactive'
+  let src_span = srcLocSpan interactiveSrcLoc
+  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
+  let hvals_io = unsafeCoerce# hval :: IO [HValue]
+
+  return $ Just (ids, hvals_io, fix_env)
 
 -- | Compile a decls
 hscDecls :: HscEnv
@@ -1533,14 +1540,9 @@ hscTcExpr :: HscEnv
           -> String -- ^ The expression
           -> IO Type
 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
-    hsc_env <- getHscEnv
-    maybe_stmt <- hscParseStmt expr
-    case maybe_stmt of
-        Just (L _ (BodyStmt expr _ _ _)) ->
-            ioMsgMaybe $ tcRnExpr hsc_env expr
-        _ ->
-            throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
-                (text "not an expression:" <+> quotes (text expr))
+  hsc_env <- getHscEnv
+  parsed_expr <- hscParseExpr expr
+  ioMsgMaybe $ tcRnExpr hsc_env parsed_expr
 
 -- | Find the kind of a type
 -- Currently this does *not* generalise the kinds of the type
@@ -1554,6 +1556,15 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
     ty <- hscParseType str
     ioMsgMaybe $ tcRnType hsc_env normalise ty
 
+hscParseExpr :: String -> Hsc (LHsExpr RdrName)
+hscParseExpr expr = do
+  hsc_env <- getHscEnv
+  maybe_stmt <- hscParseStmt expr
+  case maybe_stmt of
+    Just (L _ (BodyStmt expr _ _ _)) -> return expr
+    _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
+      (text "not an expression:" <+> quotes (text expr))
+
 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
 hscParseStmt = hscParseThing parseStmt
 
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 122d565289..6b0c4851e1 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -33,6 +33,7 @@ module InteractiveEval (
         parseName,
         showModule,
         isModuleInterpreted,
+        parseExpr, compileParsedExpr,
         compileExpr, dynCompileExpr,
         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
         -- * Depcreated API (remove in GHC 7.14)
@@ -72,6 +73,7 @@ import Unique
 import UniqSupply
 import MonadUtils
 import Module
+import PrelNames  ( toDynName )
 import Panic
 import UniqFM
 import Maybes
@@ -81,6 +83,7 @@ import BreakArray
 import RtClosureInspect
 import Outputable
 import FastString
+import Bag
 
 import System.Mem.Weak
 import System.Directory
@@ -1002,45 +1005,49 @@ typeKind normalise str = withSession $ \hsc_env -> do
    liftIO $ hscKcType hsc_env normalise str
 
 -----------------------------------------------------------------------------
--- Compile an expression, run it and deliver the resulting HValue
+-- Compile an expression, run it and deliver the result
 
+-- | Parse an expression, the parsed expression can be further processed and
+-- passed to compileParsedExpr.
+parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName)
+parseExpr expr = withSession $ \hsc_env -> do
+  liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
+
+-- | Compile an expression, run it and deliver the resulting HValue.
 compileExpr :: GhcMonad m => String -> m HValue
-compileExpr expr = withSession $ \hsc_env -> do
-  Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+compileExpr expr = do
+  parsed_expr <- parseExpr expr
+  compileParsedExpr parsed_expr
+
+-- | Compile an parsed expression (before renaming), run it and deliver
+-- the resulting HValue.
+compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
+compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
+  -- > let _compileParsedExpr = expr
+  -- Create let stmt from expr to make hscParsedStmt happy.
+  -- We will ignore the returned [Id], namely [expr_id], and not really
+  -- create a new binding.
+  let expr_fs = fsLit "_compileParsedExpr"
+      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
+      let_stmt = L loc . LetStmt . HsValBinds $
+        ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
+
+  Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
   updateFixityEnv fix_env
-  hvals <- liftIO hval
-  case (ids,hvals) of
-    ([_],[hv]) -> return hv
-    _          -> panic "compileExpr"
-
--- -----------------------------------------------------------------------------
--- Compile an expression, run it and return the result as a dynamic
+  hvals <- liftIO hvals_io
+  case (ids, hvals) of
+    ([_expr_id], [hval]) -> return hval
+    _ -> panic "compileParsedExpr"
 
+-- | Compile an expression, run it and return the result as a Dynamic.
 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 dynCompileExpr expr = do
-    iis <- getContext
-    let importDecl = ImportDecl {
-                         ideclSourceSrc = Nothing,
-                         ideclName = noLoc (mkModuleName "Data.Dynamic"),
-                         ideclPkgQual = Nothing,
-                         ideclSource = False,
-                         ideclSafe = False,
-                         ideclQualified = True,
-                         ideclImplicit = False,
-                         ideclAs = Nothing,
-                         ideclHiding = Nothing
-                     }
-    setContext (IIDecl importDecl : iis)
-    let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
-    Just (ids, hvals, fix_env) <- withSession $ \hsc_env ->
-                           liftIO $ hscStmt hsc_env stmt
-    setContext iis
-    updateFixityEnv fix_env
-
-    vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
-    case (ids,vals) of
-        (_:[], v:[]) -> return v
-        _            -> panic "dynCompileExpr"
+  parsed_expr <- parseExpr expr
+  -- > Data.Dynamic.toDyn expr
+  let loc = getLoc parsed_expr
+      to_dyn_expr = mkHsApp (L loc . HsVar $ getRdrName toDynName) parsed_expr
+  hval <- compileParsedExpr to_dyn_expr
+  return (unsafeCoerce# hval :: Dynamic)
 
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames