blob: ce33e50daec99387c3d8a361b70194d56bf59482 (
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
|
{-# 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
compileInGhc :: [FilePath] -- ^ Targets
-> (String -> IO ()) -- ^ handler for each SevOutput 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_ 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 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)
|
