cbaf9277d5f63ebd2ba282657469e3c103668ff0
[ghc.git] / iserv / Main.hs
1 {-# LANGUAGE RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-}
2 module Main (main) where
3
4 import GHCi.Run
5 import GHCi.TH
6 import GHCi.Message
7 import GHCi.Signals
8
9 import Control.DeepSeq
10 import Control.Exception
11 import Control.Monad
12 import Data.Binary
13 import Data.IORef
14 import System.Environment
15 import System.Exit
16 import System.Posix
17 import Text.Printf
18
19 main :: IO ()
20 main = do
21 (arg0:arg1:rest) <- getArgs
22 let wfd1 = read arg0; rfd2 = read arg1
23 verbose <- case rest of
24 ["-v"] -> return True
25 [] -> return False
26 _ -> die "iserv: syntax: iserv <write-fd> <read-fd> [-v]"
27 when verbose $ do
28 printf "GHC iserv starting (in: %d; out: %d)\n"
29 (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
30 inh <- fdToHandle rfd2
31 outh <- fdToHandle wfd1
32 installSignalHandlers
33 lo_ref <- newIORef Nothing
34 let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
35 uninterruptibleMask $ serv verbose pipe
36 -- we cannot allow any async exceptions while communicating, because
37 -- we will lose sync in the protocol, hence uninterruptibleMask.
38
39 serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO ()
40 serv verbose pipe@Pipe{..} restore = loop
41 where
42 loop = do
43 Msg msg <- readPipe pipe getMessage
44 discardCtrlC
45 when verbose $ putStrLn ("iserv: " ++ show msg)
46 case msg of
47 Shutdown -> return ()
48 RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
49 FinishTH st -> wrapRunTH $ finishTH pipe st
50 _other -> run msg >>= reply
51
52 reply :: forall a. (Binary a, Show a) => a -> IO ()
53 reply r = do
54 when verbose $ putStrLn ("iserv: return: " ++ show r)
55 writePipe pipe (put r)
56 loop
57
58 wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
59 wrapRunTH io = do
60 r <- try io
61 case r of
62 Left e
63 | Just (GHCiQException _ err) <- fromException e -> do
64 when verbose $ putStrLn "iserv: QFail"
65 writePipe pipe (putMessage (QFail err))
66 loop
67 | otherwise -> do
68 when verbose $ putStrLn "iserv: QException"
69 str <- showException e
70 writePipe pipe (putMessage (QException str))
71 loop
72 Right a -> do
73 when verbose $ putStrLn "iserv: QDone"
74 writePipe pipe (putMessage QDone)
75 reply a
76
77 -- carefully when showing an exception, there might be other exceptions
78 -- lurking inside it. If so, we return the inner exception instead.
79 showException :: SomeException -> IO String
80 showException e0 = do
81 r <- try $ evaluate (force (show (e0::SomeException)))
82 case r of
83 Left e -> showException e
84 Right str -> return str
85
86 -- throw away any pending ^C exceptions while we're not running
87 -- interpreted code. GHC will also get the ^C, and either ignore it
88 -- (if this is GHCi), or tell us to quit with a Shutdown message.
89 discardCtrlC = do
90 r <- try $ restore $ return ()
91 case r of
92 Left UserInterrupt -> return () >> discardCtrlC
93 Left e -> throwIO e
94 _ -> return ()