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

15 files changed, 226 insertions, 98 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
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index 4d1cd9af95..5ab060e941 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -36,6 +36,8 @@ import TysWiredIn
 import HscTypes
 import Class
 import TyCon
+import Outputable
+import UniqFM
 import Util
 import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
 
@@ -53,13 +55,20 @@ import Data.Array
 ********************************************************************* -}
 
 knownKeyNames :: [Name]
-knownKeyNames
-  = map getName wiredInThings
-    ++ cTupleTyConNames
-    ++ basicKnownKeyNames
+knownKeyNames =
+  ASSERT2( isNullUFM badNamesUFM, text "badknownKeyNames" <+> ppr badNamesUFM )
+  names
+  where
+  badNamesUFM = filterUFM (\ns -> length ns > 1) namesUFM
+  namesUFM = foldl (\m n -> addToUFM_Acc (:) singleton m n n) emptyUFM names
+  names = concat
+    [ map getName wiredInThings
+    , cTupleTyConNames
+    , basicKnownKeyNames
 #ifdef GHCI
-    ++ templateHaskellNames
+    , templateHaskellNames
 #endif
+    ]
 
 {- *********************************************************************
 *                                                                      *
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index ded9583c62..8b60088666 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -170,12 +170,6 @@ isUnboundName name = name `hasKey` unboundKey
 This section tells what the compiler knows about the association of
 names with uniques.  These ones are the *non* wired-in ones.  The
 wired in ones are defined in TysWiredIn etc.
-
-The names for DPH can come from one of multiple backend packages. At the point where
-'basicKnownKeyNames' is used, we don't know which backend it will be.  Hence, we list
-the names for multiple backends.  That works out fine, although they use the same uniques,
-as we are guaranteed to only load one backend; hence, only one of the different names
-sharing a unique will be used.
 -}
 
 basicKnownKeyNames :: [Name]
@@ -188,7 +182,6 @@ basicKnownKeyNames
         stringTyConName,
         ratioDataConName,
         ratioTyConName,
-        integerTyConName,
 
         --  Classes.  *Must* include:
         --      classes that are grabbed by key (e.g., eqClassKey)
@@ -221,6 +214,8 @@ basicKnownKeyNames
         mkAppTyName,
         typeLitTypeRepName,
 
+        -- Dynamic
+        toDynName,
 
         -- Numeric stuff
         negateName, minusName, geName, eqName,
@@ -247,8 +242,8 @@ basicKnownKeyNames
         fmapName,
         joinMName,
 
-        -- MonadRec stuff
-        mfixName,
+        -- MonadFix
+        monadFixClassName, mfixName,
 
         -- Arrow stuff
         arrAName, composeAName, firstAName,
@@ -318,9 +313,6 @@ basicKnownKeyNames
         rationalToFloatName,
         rationalToDoubleName,
 
-        -- MonadFix
-        monadFixClassName, mfixName,
-
         -- Other classes
         randomClassName, randomGenClassName, monadPlusClassName,
 
@@ -1038,7 +1030,9 @@ mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPol
 mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
 typeLitTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey
 
-
+-- Dynamic
+toDynName :: Name
+toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey
 
 -- Class Data
 dataClassName :: Name
@@ -1887,6 +1881,9 @@ mkPolyTyConAppKey = mkPreludeMiscIdUnique 504
 mkAppTyKey        = mkPreludeMiscIdUnique 505
 typeLitTypeRepKey = mkPreludeMiscIdUnique 506
 
+-- Dynamic
+toDynIdKey :: Unique
+toDynIdKey = mkPreludeMiscIdUnique 507
 
 {-
 ************************************************************************
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 6e4880b987..a0223c184c 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -36,13 +36,15 @@ import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
              TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
              handleSourceError )
 import HsImpExp
+import HsSyn
 import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
                   setInteractivePrintName )
 import Module
 import Name
 import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
 import PprTyThing
-import RdrName ( getGRE_NameQualifier_maybes )
+import PrelNames
+import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
 import SrcLoc
 import qualified Lexer
 
@@ -1317,14 +1319,18 @@ defineMacro overwrite s = do
 
   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
 
-  -- give the expression a type signature, so we can be sure we're getting
-  -- something of the right type.
-  let new_expr = '(' : definition ++ ") :: String -> IO String"
-
   -- compile the expression
-  handleSourceError (\e -> GHC.printException e) $
-   do
-    hv <- GHC.compileExpr new_expr
+  handleSourceError GHC.printException $ do
+    step <- getGhciStepIO
+    expr <- GHC.parseExpr definition
+    -- > ghciStepIO . definition :: String -> IO String
+    let stringTy = nlHsTyVar $ getRdrName stringTyConName
+        ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+        body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr
+        tySig = stringTy `nlHsFunTy` ioM
+        new_expr = L (getLoc expr) $ ExprWithTySig body tySig PlaceHolder
+    hv <- GHC.compileParsedExpr new_expr
+
     liftIO (writeIORef macros_ref -- later defined macros have precedence
             ((macro_name, lift . runMacro hv, noCompletion) : filtered))
 
@@ -1353,15 +1359,27 @@ undefineMacro str = mapM_ undef (words str)
 -- :cmd
 
 cmdCmd :: String -> GHCi ()
-cmdCmd str = do
-  let expr = '(' : str ++ ") :: IO String"
-  handleSourceError (\e -> GHC.printException e) $
-   do
-    hv <- GHC.compileExpr expr
+cmdCmd str = handleSourceError GHC.printException $ do
+    step <- getGhciStepIO
+    expr <- GHC.parseExpr str
+    -- > ghciStepIO str :: IO String
+    let new_expr = step `mkHsApp` expr
+    hv <- GHC.compileParsedExpr new_expr
+
     cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
     enqueueCommands (lines cmds)
-    return ()
 
+-- | Generate a typed ghciStepIO expression
+-- @ghciStepIO :: Ty String -> IO String@.
+getGhciStepIO :: GHCi (LHsExpr RdrName)
+getGhciStepIO = do
+  ghciTyConName <- GHC.getGHCiMonad
+  let stringTy = nlHsTyVar $ getRdrName stringTyConName
+      ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
+      ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+      body = nlHsVar (getRdrName ghciStepIoMName)
+      tySig = ghciM `nlHsFunTy` ioM
+  return $ noLoc $ ExprWithTySig body tySig PlaceHolder
 
 -----------------------------------------------------------------------------
 -- :check
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 1716b8f9c6..21c5709c45 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -713,6 +713,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/ghc-api/T8639_api
 /tests/ghc-api/T9595
 /tests/ghc-api/T10052/T10052
+/tests/ghc-api/T10508_api
 /tests/ghc-api/apirecomp001/myghc
 /tests/ghc-api/dynCompileExpr/dynCompileExpr
 /tests/ghc-api/ghcApi
diff --git a/testsuite/tests/ghc-api/T10508_api.hs b/testsuite/tests/ghc-api/T10508_api.hs
new file mode 100644
index 0000000000..afe8e50e73
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10508_api.hs
@@ -0,0 +1,32 @@
+module Main where
+
+import DynFlags
+import GHC
+
+import Control.Monad (forM_)
+import Control.Monad.IO.Class (liftIO)
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+  [libdir] <- getArgs
+  runGhc (Just libdir) $ do
+    dflags <- getSessionDynFlags
+    setSessionDynFlags $ dflags
+      `gopt_unset` Opt_ImplicitImportQualified
+      `xopt_unset` Opt_ImplicitPrelude
+
+    forM_ exprs $ \expr ->
+      handleSourceError printException $ do
+        dyn <- dynCompileExpr expr
+        liftIO $ print dyn
+  where
+  exprs =
+    [ ""
+    , "(),()"
+    , "()"
+    , "\"test\""
+    , unlines [ "[()]"
+              , " :: [()]"
+              ]
+    ]
diff --git a/testsuite/tests/ghc-api/T10508_api.stderr b/testsuite/tests/ghc-api/T10508_api.stderr
new file mode 100644
index 0000000000..29533435f3
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10508_api.stderr
@@ -0,0 +1,4 @@
+
+<no location info>: error: not an expression: ‘’
+
+<interactive>:1:3: error: parse error on input ‘,’
diff --git a/testsuite/tests/ghc-api/T10508_api.stdout b/testsuite/tests/ghc-api/T10508_api.stdout
new file mode 100644
index 0000000000..9a6eb4c38f
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10508_api.stdout
@@ -0,0 +1,3 @@
+<<()>>
+<<[Char]>>
+<<[()]>>
diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T
index 11e8c422b6..c4783ea15d 100644
--- a/testsuite/tests/ghc-api/all.T
+++ b/testsuite/tests/ghc-api/all.T
@@ -8,4 +8,9 @@ test('T8639_api', normal,
 test('T8628', normal,
               run_command,
               ['$MAKE -s --no-print-directory T8628'])
-test('T9595', extra_run_opts('"' + config.libdir + '"'), compile_and_run, ['-package ghc'])
+test('T9595', extra_run_opts('"' + config.libdir + '"'),
+              compile_and_run,
+              ['-package ghc'])
+test('T10508_api', extra_run_opts('"' + config.libdir + '"'),
+                   compile_and_run,
+                   ['-package ghc'])
diff --git a/testsuite/tests/ghci/scripts/T10508.script b/testsuite/tests/ghci/scripts/T10508.script
new file mode 100644
index 0000000000..5ac770060b
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T10508.script
@@ -0,0 +1,21 @@
+-- :cmd accepts an expr of type 'IO String'
+let cmd = return "0"
+:cmd cmd
+
+-- works with multiline mode, handles indention correctly
+:{
+:cmd return $ unlines
+  [ "1"
+  , "2"
+  ]
+:}
+
+-- it should work even 'IO' or 'String' is not in scope
+import Prelude ()
+:cmd cmd
+
+-- or even when a different 'String' is in scope
+import Prelude
+type String = ShowS
+:def macro \_ -> return id
+:macro
diff --git a/testsuite/tests/ghci/scripts/T10508.stderr b/testsuite/tests/ghci/scripts/T10508.stderr
new file mode 100644
index 0000000000..c5aff2361c
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T10508.stderr
@@ -0,0 +1,8 @@
+
+<interactive>:1:15:
+    Couldn't match type ‘a0 -> a0’ with ‘[Char]’
+    Expected type: Prelude.String
+      Actual type: a0 -> a0
+    Probable cause: ‘id’ is applied to too few arguments
+    In the first argument of ‘return’, namely ‘id’
+    In the expression: return id
\ No newline at end of file
diff --git a/testsuite/tests/ghci/scripts/T10508.stdout b/testsuite/tests/ghci/scripts/T10508.stdout
new file mode 100644
index 0000000000..c6c8d3a447
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T10508.stdout
@@ -0,0 +1,6 @@
+0
+1
+2
+0
+unknown command ':macro'
+use :? for help.
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index df02add5b4..c2c75ecb94 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -221,3 +221,4 @@ test('T10110', normal, ghci_script, ['T10110.script'])
 test('T10322', normal, ghci_script, ['T10322.script'])
 test('T10466', normal, ghci_script, ['T10466.script'])
 test('T10501', normal, ghci_script, ['T10501.script'])
+test('T10508', normal, ghci_script, ['T10508.script'])