summaryrefslogtreecommitdiff
path: root/testsuite/tests/ghc-api/T4891
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/ghc-api/T4891')
-rw-r--r--testsuite/tests/ghc-api/T4891/Makefile13
-rw-r--r--testsuite/tests/ghc-api/T4891/T4891.hs70
-rw-r--r--testsuite/tests/ghc-api/T4891/T4891.stdout20
-rw-r--r--testsuite/tests/ghc-api/T4891/X.hs5
-rw-r--r--testsuite/tests/ghc-api/T4891/all.T3
5 files changed, 111 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-api/T4891/Makefile b/testsuite/tests/ghc-api/T4891/Makefile
new file mode 100644
index 0000000000..e19228089f
--- /dev/null
+++ b/testsuite/tests/ghc-api/T4891/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+ rm -f *.o *.hi
+
+T4891: clean
+ '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc T4891
+ ./T4891 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+.PHONY: clean T4891
+
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
+
diff --git a/testsuite/tests/ghc-api/T4891/T4891.stdout b/testsuite/tests/ghc-api/T4891/T4891.stdout
new file mode 100644
index 0000000000..47eb152467
--- /dev/null
+++ b/testsuite/tests/ghc-api/T4891/T4891.stdout
@@ -0,0 +1,20 @@
+=====
+Name: GHC.Types.False
+OccString: 'False'
+DataCon: GHC.Types.False
+=====
+Name: :
+OccString: ':'
+DataCon: :
+=====
+Name: X.:->
+OccString: ':->'
+DataCon: X.:->
+=====
+Name: X.:->.
+OccString: ':->.'
+DataCon: X.:->.
+=====
+Name: X.:->.+
+OccString: ':->.+'
+DataCon: X.:->.+
diff --git a/testsuite/tests/ghc-api/T4891/X.hs b/testsuite/tests/ghc-api/T4891/X.hs
new file mode 100644
index 0000000000..aca63eead5
--- /dev/null
+++ b/testsuite/tests/ghc-api/T4891/X.hs
@@ -0,0 +1,5 @@
+module X where
+
+data X = Int :-> Int
+ | Int :->. Int
+ | Int :->.+ Int
diff --git a/testsuite/tests/ghc-api/T4891/all.T b/testsuite/tests/ghc-api/T4891/all.T
new file mode 100644
index 0000000000..5217e5371f
--- /dev/null
+++ b/testsuite/tests/ghc-api/T4891/all.T
@@ -0,0 +1,3 @@
+test('T4891', [skip_if_fast, extra_clean(['X.hi', 'X.o'])],
+ run_command,
+ ['$MAKE -s --no-print-directory T4891'])