Ticket #7430: GhcRun.hs

File GhcRun.hs, 2.3 KB (added by MikolajKonarski, 2 years ago)
Line 
1module Main where
2
3import GHC hiding (flags, ModuleName)
4import qualified Config as GHC
5import ErrUtils   ( MsgDoc )
6import Outputable ( PprStyle, showSDocForUser, qualName, qualModule )
7import FastString ( unpackFS )
8import StringBuffer ( stringToStringBuffer )
9
10import System.Process
11import Data.Time
12import Data.IORef
13import Control.Applicative
14import qualified Control.Exception as Ex
15
16main :: IO ()
17main =
18  handleOtherErrors $ do
19
20    libdir <- getGhcLibdir
21
22    runGhc (Just libdir) $
23      handleSourceError printException $ do
24
25      flags0 <- getSessionDynFlags
26      (flags, _, _) <- parseDynamicFlags flags0 $ [noLoc "-XCPP"]
27
28      defaultCleanupHandler flags $ do
29        setSessionDynFlags flags {
30                             hscTarget  = HscNothing,
31                             ghcLink    = NoLink,
32                             ghcMode    = CompManager,
33                             log_action = collectSrcError,
34                             verbosity  = 1
35                           }
36        addTarget Target
37                { targetId           = TargetFile "Ticks.hs" Nothing
38                , targetAllowObjCode = True
39                , targetContents     = Nothing
40                }
41        load LoadAllTargets
42        return ()
43
44    return ()
45  where
46    handleOtherErrors =
47      Ex.handle $ \e ->
48        putStrLn $ "Exception:\n" ++ show (e :: Ex.SomeException) ++ "\n"
49
50getGhcLibdir :: IO FilePath
51getGhcLibdir = do
52  let ghcbinary = "ghc-" ++ GHC.cProjectVersion
53  out <- readProcess ghcbinary ["--print-libdir"] ""
54  case lines out of
55    [libdir] -> return libdir
56    _        -> fail "cannot parse output of ghc --print-libdir"
57
58collectSrcError :: DynFlags
59                -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
60collectSrcError flags severity srcspan style msg = do
61  let showSeverity SevOutput  = "SevOutput"
62      showSeverity SevDump    = "SevDump"
63      showSeverity SevInfo    = "SevInfo"
64      showSeverity SevWarning = "SevWarning"
65      showSeverity SevError   = "SevError"
66      showSeverity SevFatal   = "SevFatal"
67  putStrLn
68    $  "Normal error message:\nSeverity: "   ++ showSeverity severity
69    ++ "  SrcSpan: "  ++ show srcspan
70--    ++ "  PprStyle: " ++ show style
71    ++ "  MsgDoc: "   ++ showSDocForUser flags (qualName style,qualModule style) msg
72    ++ "\n"