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