15c3559f7dfa75b82591fe361419d4ee49cd6984
[ghc.git] / testsuite / tests / ghc-api / T7478 / T7478.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 module Main (main) where
3
4 import Data.List ((\\))
5 import Control.Monad (void)
6 import System.Environment
7
8 import GHC
9 import qualified Config as GHC
10 import qualified Outputable as GHC
11 import GhcMonad (liftIO)
12 import Outputable (PprStyle, qualName, qualModule)
13
14 compileInGhc :: [FilePath] -- ^ Targets
15 -> (String -> IO ()) -- ^ handler for each SevOutput message
16 -> Ghc ()
17 compileInGhc targets handlerOutput = do
18 -- Set flags
19 flags0 <- getSessionDynFlags
20 let flags = flags0 {verbosity = 1, log_action = collectSrcError handlerOutput}
21 setSessionDynFlags flags
22 -- Set up targets.
23 oldTargets <- getTargets
24 let oldFiles = map fileFromTarget oldTargets
25 mapM_ addSingle (targets \\ oldFiles)
26 mapM_ (removeTarget . targetIdFromFile) $ oldFiles \\ targets
27 -- Load modules to typecheck
28 void $ load LoadAllTargets
29 where
30 targetIdFromFile file = TargetFile file Nothing
31
32 addSingle filename =
33 addTarget Target
34 { targetId = targetIdFromFile filename
35 , targetAllowObjCode = True
36 , targetContents = Nothing
37 }
38
39 fileFromTarget Target{targetId} =
40 case targetId of
41 TargetFile file Nothing -> file
42 _ -> error "fileFromTarget: not a known target"
43
44 collectSrcError handlerOutput flags SevOutput _srcspan style msg
45 = handlerOutput $ GHC.showSDocForUser flags (qualName style,qualModule style) msg
46 collectSrcError _ _ _ _ _ _
47 = return ()
48
49 main :: IO ()
50 main = do
51 [libdir] <- getArgs
52 runGhc (Just libdir) $ do
53
54 liftIO $ putStrLn "----- 0 ------"
55 compileInGhc ["A.hs", "B.hs"] $ \msg -> print (0 :: Int, msg)
56
57 liftIO $ putStrLn "----- 1 ------"
58 compileInGhc ["A.hs", "B.hs"] $ \msg -> print (1 :: Int, msg)
59
60 liftIO $ putStrLn "----- 2 ------"
61 compileInGhc ["C.hs"] $ \msg -> print (2 :: Int, msg)