1 files changed, 70 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs
new file mode 100644
index 0000000000..977f854e19
--- /dev/null
+++ b/testsuite/tests/ghc-api/T4891/T4891.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import ByteCodeLink
+import CoreMonad
+import Data.Array
+import DataCon
+import GHC
+import HscTypes
+import Linker
+import RtClosureInspect
+import TcEnv
+import Type
+import TcRnMonad
+import TcType
+import Control.Applicative
+import Name (getOccString)
+import Unsafe.Coerce
+import Control.Monad
+import Data.Maybe
+import Bag
+import PrelNames (iNTERACTIVE)
+import Outputable
+import GhcMonad
+import X
+
+import System.Environment
+
+main :: IO ()
+main = do [libdir] <- getArgs
+          runGhc (Just libdir) doit
+
+doit :: Ghc ()
+doit = do
+  dflags' <- getSessionDynFlags
+  primPackages <- setSessionDynFlags dflags'
+  dflags <- getSessionDynFlags
+  defaultCleanupHandler dflags $ do
+    target <- guessTarget "X.hs" Nothing
+    setTargets [target]
+    load LoadAllTargets
+
+    () <- chaseConstructor (unsafeCoerce False)
+    () <- chaseConstructor (unsafeCoerce [1,2,3])
+    () <- chaseConstructor (unsafeCoerce (3 :-> 2))
+    () <- chaseConstructor (unsafeCoerce (4 :->. 4))
+    () <- chaseConstructor (unsafeCoerce (4 :->.+ 4))
+    return ()
+
+chaseConstructor :: (GhcMonad m) => HValue -> m ()
+chaseConstructor !hv = do
+  liftIO $ putStrLn "====="
+  closure <- liftIO $ getClosureData hv
+  case tipe closure  of
+    Indirection _ -> chaseConstructor (ptrs closure ! 0)
+    Constr -> do
+      withSession $ \hscEnv -> liftIO $ initTcForLookup hscEnv $ do
+        eDcname <- dataConInfoPtrToName (infoPtr closure)
+        case eDcname of
+          Left _       -> return ()
+          Right dcName -> do
+            liftIO $ putStrLn $ "Name: "      ++ showPpr dcName
+            liftIO $ putStrLn $ "OccString: " ++ "'" ++ getOccString dcName ++ "'"
+            dc <- tcLookupDataCon dcName
+            liftIO $ putStrLn $ "DataCon: "   ++ showPpr dc
+    _ -> return ()
+
+initTcForLookup :: HscEnv -> TcM a -> IO a
+initTcForLookup hsc_env = liftM (\(msg, mValue) -> fromMaybe (error . show . bagToList . snd $ msg) mValue) . initTc hsc_env HsSrcFile False iNTERACTIVE
+