13 files changed, 233 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-api/Makefile b/testsuite/tests/ghc-api/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/ghc-api/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
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'])
diff --git a/testsuite/tests/ghc-api/apirecomp001/A.hs b/testsuite/tests/ghc-api/apirecomp001/A.hs
new file mode 100644
index 0000000000..0e65d28676
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/A.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -Wall #-}
+module A where
+
+import B
+import System.IO
+
+main = do
+    print answer_to_live_the_universe_and_everything
+    hFlush stdout
diff --git a/testsuite/tests/ghc-api/apirecomp001/B.hs b/testsuite/tests/ghc-api/apirecomp001/B.hs
new file mode 100644
index 0000000000..81b17a4404
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/B.hs
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -Wall #-}
+module B where
+
+answer_to_live_the_universe_and_everything =
+    length [1..23*2] - 4
+\ No newline at end of file
diff --git a/testsuite/tests/ghc-api/apirecomp001/Makefile b/testsuite/tests/ghc-api/apirecomp001/Makefile
new file mode 100644
index 0000000000..e2b88c8e51
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/Makefile
@@ -0,0 +1,11 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+	rm -f *.o *.hi
+
+apirecomp001: clean
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc myghc.hs
+	./myghc "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
diff --git a/testsuite/tests/ghc-api/apirecomp001/all.T b/testsuite/tests/ghc-api/apirecomp001/all.T
new file mode 100644
index 0000000000..0aa92874dc
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/all.T
@@ -0,0 +1 @@
+test('apirecomp001', skip_if_fast, run_command, ['$MAKE -s --no-print-directory apirecomp001'])
diff --git a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr
new file mode 100644
index 0000000000..dd8fa9e89e
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr
@@ -0,0 +1,32 @@
+
+B.hs:4:1:
+    Warning: Top-level binding with no type signature:
+               answer_to_live_the_universe_and_everything :: Int
+
+B.hs:5:12:
+    Warning: Defaulting the following constraint(s) to type `Integer'
+               (Enum a0) arising from the arithmetic sequence `1 .. 23 * 2'
+                         at B.hs:5:12-20
+               (Num a0) arising from the literal `2' at B.hs:5:19
+    In the first argument of `length', namely `[1 .. 23 * 2]'
+    In the first argument of `(-)', namely `length [1 .. 23 * 2]'
+    In the expression: length [1 .. 23 * 2] - 4
+
+A.hs:7:1:
+    Warning: Top-level binding with no type signature: main :: IO ()
+
+B.hs:4:1:
+    Warning: Top-level binding with no type signature:
+               answer_to_live_the_universe_and_everything :: Int
+
+B.hs:5:12:
+    Warning: Defaulting the following constraint(s) to type `Integer'
+               (Enum a0) arising from the arithmetic sequence `1 .. 23 * 2'
+                         at B.hs:5:12-20
+               (Num a0) arising from the literal `2' at B.hs:5:19
+    In the first argument of `length', namely `[1 .. 23 * 2]'
+    In the first argument of `(-)', namely `length [1 .. 23 * 2]'
+    In the expression: length [1 .. 23 * 2] - 4
+
+A.hs:7:1:
+    Warning: Top-level binding with no type signature: main :: IO ()
diff --git a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stdout b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stdout
new file mode 100644
index 0000000000..d42bf17f3a
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stdout
@@ -0,0 +1,4 @@
+target nothing: ok
+target interpreted: ok
+42
+ok
diff --git a/testsuite/tests/ghc-api/apirecomp001/myghc.hs b/testsuite/tests/ghc-api/apirecomp001/myghc.hs
new file mode 100644
index 0000000000..ec2e4a78f7
--- /dev/null
+++ b/testsuite/tests/ghc-api/apirecomp001/myghc.hs
@@ -0,0 +1,57 @@
+-- 1. Load a set of modules with "nothing" target
+-- 2. Load it again with "interpreted" target
+-- 3. Execute some code
+--    a. If the recompilation checker is buggy this will die due to missing
+--       code
+--    b. If it's correct, it will recompile because the target has changed.
+--
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+import GHC
+import DynFlags
+import MonadUtils ( MonadIO(..) )
+import BasicTypes ( failed )
+import Bag        ( bagToList )
+import System.Environment
+import Control.Monad
+import System.IO
+
+main = do
+  [libdir] <- getArgs
+  runGhc (Just libdir) $ do
+    dflags <- getSessionDynFlags
+    setSessionDynFlags $ dflags { hscTarget = HscNothing
+                                , ghcLink  = LinkInMemory
+                                , verbosity = 0 -- silence please
+                                }
+    root_mod <- guessTarget "A.hs" Nothing
+    setTargets [root_mod]
+    ok <- load LoadAllTargets
+    when (failed ok) $ error "Couldn't load A.hs in nothing mode"
+    prn "target nothing: ok"
+
+    dflags <- getSessionDynFlags
+    setSessionDynFlags $ dflags { hscTarget = HscInterpreted }
+    ok <- load LoadAllTargets
+    when (failed ok) $ error "Couldn't load A.hs in interpreted mode"
+    prn "target interpreted: ok"
+
+    -- set context to module "A"
+    mg <- getModuleGraph
+    let [mod] = [ ms_mod m | m <- mg, moduleNameString (ms_mod_name m) == "A" ]
+    setContext [mod] []
+    liftIO $ hFlush stdout  -- make sure things above are printed before
+                            -- interactive output
+    r <- runStmt "main" RunToCompletion
+    case r of
+      RunOk _        -> prn "ok"
+      RunFailed      -> prn "compilation failed"
+      RunException _ -> prn "exception"
+      RunBreak _ _ _ -> prn "breakpoint"
+    liftIO $ hFlush stdout
+    return ()
+
+prn :: MonadIO m => String -> m ()
+prn = liftIO . putStrLn