Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
http://hackage.haskell.org/trac/ghc/changeset/4db1bbca988304cc626b3e874c7547d3b5317328 >--------------------------------------------------------------- commit 4db1bbca988304cc626b3e874c7547d3b5317328 Author: Ian Lynagh <[email protected]> Date: Sun Apr 3 15:36:57 2011 +0100 Add a test for #4891 >--------------------------------------------------------------- tests/ghc-regress/ghc-api/T4891/Makefile | 13 +++++ tests/ghc-regress/ghc-api/T4891/T4891.hs | 64 ++++++++++++++++++++++++++ tests/ghc-regress/ghc-api/T4891/T4891.stdout | 20 ++++++++ tests/ghc-regress/ghc-api/T4891/X.hs | 5 ++ tests/ghc-regress/ghc-api/T4891/all.T | 3 + 5 files changed, 105 insertions(+), 0 deletions(-) diff --git a/tests/ghc-regress/ghc-api/T4891/Makefile b/tests/ghc-regress/ghc-api/T4891/Makefile new file mode 100644 index 0000000..592bde0 --- /dev/null +++ b/tests/ghc-regress/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)' --make -v0 -package ghc T4891 + ./T4891 "`'$(TEST_HC)' --print-libdir | tr -d '\r'`" + +.PHONY: clean T4891 + diff --git a/tests/ghc-regress/ghc-api/T4891/T4891.hs b/tests/ghc-regress/ghc-api/T4891/T4891.hs new file mode 100644 index 0000000..8dd3686 --- /dev/null +++ b/tests/ghc-regress/ghc-api/T4891/T4891.hs @@ -0,0 +1,64 @@ +{-# 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 + +main :: IO () +main = runGhc (Just "/home/ian/ghc/git/ghc/inplace/lib") $ 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/tests/ghc-regress/ghc-api/T4891/T4891.stdout b/tests/ghc-regress/ghc-api/T4891/T4891.stdout new file mode 100644 index 0000000..47eb152 --- /dev/null +++ b/tests/ghc-regress/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/tests/ghc-regress/ghc-api/T4891/X.hs b/tests/ghc-regress/ghc-api/T4891/X.hs new file mode 100644 index 0000000..aca63ee --- /dev/null +++ b/tests/ghc-regress/ghc-api/T4891/X.hs @@ -0,0 +1,5 @@ +module X where + +data X = Int :-> Int + | Int :->. Int + | Int :->.+ Int diff --git a/tests/ghc-regress/ghc-api/T4891/all.T b/tests/ghc-regress/ghc-api/T4891/all.T new file mode 100644 index 0000000..5217e53 --- /dev/null +++ b/tests/ghc-regress/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']) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
