blob: 57e65706c34e006d7f56c3c2619e56e3cf1f810b (
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
69
70
71
|
{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
module Lib (serv) where
import GHCi.Run
import GHCi.TH
import GHCi.Message
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Binary
type MessageHook = Msg -> IO Msg
serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv verbose hook pipe@Pipe{..} restore = loop
where
loop = do
Msg msg <- readPipe pipe getMessage >>= hook
discardCtrlC
when verbose $ putStrLn ("iserv: " ++ show msg)
case msg of
Shutdown -> return ()
RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
_other -> run msg >>= reply
reply :: forall a. (Binary a, Show a) => a -> IO ()
reply r = do
when verbose $ putStrLn ("iserv: return: " ++ show r)
writePipe pipe (put r)
loop
-- Run some TH code, which may interact with GHC by sending
-- THMessage requests, and then finally send RunTHDone followed by a
-- QResult. For an overview of how TH works with Remote GHCi, see
-- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH io = do
r <- try io
writePipe pipe (putTHMessage RunTHDone)
case r of
Left e
| Just (GHCiQException _ err) <- fromException e ->
reply (QFail err :: QResult a)
| otherwise -> do
str <- showException e
reply (QException str :: QResult a)
Right a -> do
when verbose $ putStrLn "iserv: QDone"
reply (QDone a)
-- carefully when showing an exception, there might be other exceptions
-- lurking inside it. If so, we return the inner exception instead.
showException :: SomeException -> IO String
showException e0 = do
r <- try $ evaluate (force (show (e0::SomeException)))
case r of
Left e -> showException e
Right str -> return str
-- throw away any pending ^C exceptions while we're not running
-- interpreted code. GHC will also get the ^C, and either ignore it
-- (if this is GHCi), or tell us to quit with a Shutdown message.
discardCtrlC = do
r <- try $ restore $ return ()
case r of
Left UserInterrupt -> return () >> discardCtrlC
Left e -> throwIO e
_ -> return ()
|
