blob: dbea3f9547b05bdc4f7219b1b5ad0bd2937f0ced (
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
62
63
64
65
66
67
68
|
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE NamedFieldPuns #-}
module Main (main) where
import Data.List ((\\))
import Control.Monad (void)
import System.Environment
import GHC
import qualified GHC.Settings.Config as GHC
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Ppr as GHC
import GHC.Driver.Monad (liftIO)
import GHC.Utils.Outputable (PprStyle, queryQual)
import GHC.Unit.State
import GHC.Types.Error
compileInGhc :: [FilePath] -- ^ Targets
-> (String -> IO ()) -- ^ handler for each MCOutput message
-> Ghc ()
compileInGhc targets handlerOutput = do
-- Set flags
flags0 <- getSessionDynFlags
let flags = flags0 {verbosity = 1 }
setSessionDynFlags flags
pushLogHookM (const (collectSrcError handlerOutput))
-- Set up targets.
oldTargets <- getTargets
let oldFiles = map fileFromTarget oldTargets
mapM_ (\filename -> addSingle filename (homeUnitId_ flags)) (targets \\ oldFiles)
mapM_ (removeTarget . targetIdFromFile) $ oldFiles \\ targets
-- Load modules to typecheck
void $ load LoadAllTargets
where
targetIdFromFile file = TargetFile file Nothing
addSingle filename unitId =
addTarget Target
{ targetId = targetIdFromFile filename
, targetAllowObjCode = True
, targetUnitId = unitId
, targetContents = Nothing
}
fileFromTarget Target{targetId} =
case targetId of
TargetFile file Nothing -> file
_ -> error "fileFromTarget: not a known target"
collectSrcError handlerOutput flags MCOutput _srcspan msg
= handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify 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)
|
