summaryrefslogtreecommitdiff
path: root/testsuite/tests/ghc-api/target-contents/TargetContents.hs
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/ghc-api/target-contents/TargetContents.hs')
-rw-r--r--testsuite/tests/ghc-api/target-contents/TargetContents.hs150
1 files changed, 150 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs
new file mode 100644
index 0000000000..db02dbde2b
--- /dev/null
+++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import DynFlags
+import GHC
+
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Data.List
+import Data.Maybe
+import Data.Time.Calendar
+import Data.Time.Clock
+import Exception
+import HeaderInfo
+import HscTypes
+import Outputable
+import StringBuffer
+import System.Directory
+import System.Environment
+import System.Process
+import System.IO
+import Text.Printf
+
+main :: IO ()
+main = do
+ libdir:args <- getArgs
+ createDirectoryIfMissing False "outdir"
+ runGhc (Just libdir) $ do
+ dflags0 <- getSessionDynFlags
+ (dflags1, xs, warn) <- parseDynamicFlags dflags0 $ map noLoc $
+ [ "-outputdir", "./outdir"
+ , "-fno-diagnostics-show-caret"
+ ] ++ args
+ _ <- setSessionDynFlags dflags1
+
+ -- This test fails on purpose to check if the error message mentions
+ -- the source file and not the intermediary preprocessor input file
+ -- even when no preprocessor is in use. Just a sanity check.
+ go "Error" ["A"]
+ -- ^ ^-- targets
+ -- ^-- test name
+ [("A" -- this module's name
+ , "" -- pragmas
+ , [] -- imports/non exported decls
+ , [("x", "z")] -- exported decls
+ , OnDisk -- write this module to disk?
+ )
+ ]
+
+ forM_ [OnDisk, InMemory] $ \sync ->
+ -- This one fails unless CPP actually preprocessed the source
+ go ("CPP_" ++ ppSync sync) ["A"]
+ [( "A"
+ , "{-# LANGUAGE CPP #-}"
+ , ["#define y 1"]
+ , [("x", "y")]
+ , sync
+ )
+ ]
+
+ -- These check if on-disk modules can import in-memory targets and
+ -- vice-verca.
+ forM_ (words "DD MM DM MD") $ \sync@[a_sync, b_sync] -> do
+ dep <- return $ \y ->
+ [( "A"
+ , "{-# LANGUAGE CPP #-}"
+ , ["import B"]
+ , [("x", "y")]
+ , readSync a_sync
+ ),
+ ( "B"
+ , "{-# LANGUAGE CPP #-}"
+ , []
+ , [("y", y)]
+ , readSync b_sync
+ )
+ ]
+ go ("Dep_" ++ sync ++ "_AB") ["A", "B"] (dep "()")
+
+ -- This checks if error messages are correctly referring to the real
+ -- source file and not the temp preprocessor input file.
+ go ("Dep_Error_" ++ sync ++ "_AB") ["A", "B"] (dep "z")
+
+ -- Try with only one target, this is expected to fail with a module
+ -- not found error where module B is not OnDisk.
+ go ("Dep_Error_" ++ sync ++ "_A") ["A"] (dep "z")
+
+ return ()
+
+data Sync
+ = OnDisk -- | Write generated module to disk
+ | InMemory -- | Only fill targetContents, place an empty dummy module
+ -- on disk though to make Finder shut up though.
+
+ppSync OnDisk = "D"
+ppSync InMemory = "M"
+
+readSync 'D' = OnDisk
+readSync 'M' = InMemory
+
+go label targets mods = do
+ liftIO $ createDirectoryIfMissing False "./outdir"
+ setTargets []; _ <- load LoadAllTargets
+
+ liftIO $ hPutStrLn stderr $ "== " ++ label
+ t <- liftIO getCurrentTime
+ setTargets =<< catMaybes <$> mapM (mkTarget t) mods
+ ex <- gtry $ load LoadAllTargets
+ case ex of
+ Left ex -> liftIO $ hPutStrLn stderr $ show (ex :: SourceError)
+ Right _ -> return ()
+
+ mapM_ (liftIO . cleanup) mods
+ liftIO $ removeDirectoryRecursive "./outdir"
+
+ where
+ mkTarget t mod@(name,_,_,_,sync) = do
+ src <- liftIO $ genMod mod
+ return $ if not (name `elem` targets)
+ then Nothing
+ else Just $ Target
+ { targetId = TargetFile (name++".hs") Nothing
+ , targetAllowObjCode = False
+ , targetContents =
+ case sync of
+ OnDisk -> Nothing
+ InMemory ->
+ Just ( stringToStringBuffer src
+ , t
+ )
+ }
+
+genMod :: (String, String, [String], [(String, String)], Sync) -> IO String
+genMod (mod, pragmas, internal, binders, sync) = do
+ case sync of
+ OnDisk -> writeFile (mod++".hs") src
+ InMemory -> return ()
+ return src
+ where
+ exports = intercalate ", " $ map fst binders
+ decls = map (\(b,v) -> b ++ " = " ++ v) binders
+ src = unlines $
+ [ pragmas
+ , "module " ++ mod ++ " ("++ exports ++") where"
+ ] ++ internal ++ decls
+
+cleanup :: (String, String, [String], [(String, String)], Sync) -> IO ()
+cleanup (mod,_,_,_,OnDisk) = removeFile (mod++".hs")
+cleanup _ = return ()