Make Applicative a superclass of Monad
[ghc.git] / ghc / GhciMonad.hs
1 {-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}
2 {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 -----------------------------------------------------------------------------
6 --
7 -- Monadery code used in InteractiveUI
8 --
9 -- (c) The GHC Team 2005-2006
10 --
11 -----------------------------------------------------------------------------
12
13 module GhciMonad (
14 GHCi(..), startGHCi,
15 GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
16 GHCiOption(..), isOptionSet, setOption, unsetOption,
17 Command,
18 BreakLocation(..),
19 TickArray,
20 getDynFlags,
21
22 runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
23
24 printForUser, printForUserPartWay, prettyLocations,
25 initInterpBuffering, turnOffBuffering, flushInterpBuffers,
26 ) where
27
28 #include "HsVersions.h"
29
30 import qualified GHC
31 import GhcMonad hiding (liftIO)
32 import Outputable hiding (printForUser, printForUserPartWay)
33 import qualified Outputable
34 import Util
35 import DynFlags
36 import FastString
37 import HscTypes
38 import SrcLoc
39 import Module
40 import ObjLink
41 import Linker
42
43 import Exception
44 import Numeric
45 import Data.Array
46 import Data.Int ( Int64 )
47 import Data.IORef
48 import System.CPUTime
49 import System.Environment
50 import System.IO
51 import Control.Monad
52 import GHC.Exts
53
54 import System.Console.Haskeline (CompletionFunc, InputT)
55 import qualified System.Console.Haskeline as Haskeline
56 import Control.Monad.Trans.Class
57 import Control.Monad.IO.Class
58
59 #if __GLASGOW_HASKELL__ < 709
60 import Control.Applicative (Applicative(..))
61 #endif
62
63 -----------------------------------------------------------------------------
64 -- GHCi monad
65
66 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
67
68 data GHCiState = GHCiState
69 {
70 progname :: String,
71 args :: [String],
72 prompt :: String,
73 prompt2 :: String,
74 editor :: String,
75 stop :: String,
76 options :: [GHCiOption],
77 line_number :: !Int, -- input line
78 break_ctr :: !Int,
79 breaks :: ![(Int, BreakLocation)],
80 tickarrays :: ModuleEnv TickArray,
81 -- tickarrays caches the TickArray for loaded modules,
82 -- so that we don't rebuild it each time the user sets
83 -- a breakpoint.
84 -- available ghci commands
85 ghci_commands :: [Command],
86 -- ":" at the GHCi prompt repeats the last command, so we
87 -- remember is here:
88 last_command :: Maybe Command,
89 cmdqueue :: [String],
90
91 remembered_ctx :: [InteractiveImport],
92 -- the imports that the user has asked for, via import
93 -- declarations and :module commands. This list is
94 -- persistent over :reloads (but any imports for modules
95 -- that are not loaded are temporarily ignored). After a
96 -- :load, all the home-package imports are stripped from
97 -- this list.
98
99 -- See bugs #2049, #1873, #1360
100
101 transient_ctx :: [InteractiveImport],
102 -- An import added automatically after a :load, usually of
103 -- the most recently compiled module. May be empty if
104 -- there are no modules loaded. This list is replaced by
105 -- :load, :reload, and :add. In between it may be modified
106 -- by :module.
107
108 ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc)
109
110 -- help text to display to a user
111 short_help :: String,
112 long_help :: String,
113 lastErrorLocations :: IORef [(FastString, Int)]
114 }
115
116 type TickArray = Array Int [(BreakIndex,SrcSpan)]
117
118 data GHCiOption
119 = ShowTiming -- show time/allocs after evaluation
120 | ShowType -- show the type of expressions
121 | RevertCAFs -- revert CAFs after every evaluation
122 | Multiline -- use multiline commands
123 deriving Eq
124
125 data BreakLocation
126 = BreakLocation
127 { breakModule :: !GHC.Module
128 , breakLoc :: !SrcSpan
129 , breakTick :: {-# UNPACK #-} !Int
130 , onBreakCmd :: String
131 }
132
133 instance Eq BreakLocation where
134 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
135 breakTick loc1 == breakTick loc2
136
137 prettyLocations :: [(Int, BreakLocation)] -> SDoc
138 prettyLocations [] = text "No active breakpoints."
139 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
140
141 instance Outputable BreakLocation where
142 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
143 if null (onBreakCmd loc)
144 then Outputable.empty
145 else doubleQuotes (text (onBreakCmd loc))
146
147 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
148 recordBreak brkLoc = do
149 st <- getGHCiState
150 let oldActiveBreaks = breaks st
151 -- don't store the same break point twice
152 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
153 (nm:_) -> return (True, nm)
154 [] -> do
155 let oldCounter = break_ctr st
156 newCounter = oldCounter + 1
157 setGHCiState $ st { break_ctr = newCounter,
158 breaks = (oldCounter, brkLoc) : oldActiveBreaks
159 }
160 return (False, oldCounter)
161
162 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
163
164 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
165 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
166
167 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
168 reifyGHCi f = GHCi f'
169 where
170 -- f' :: IORef GHCiState -> Ghc a
171 f' gs = reifyGhc (f'' gs)
172 -- f'' :: IORef GHCiState -> Session -> IO a
173 f'' gs s = f (s, gs)
174
175 startGHCi :: GHCi a -> GHCiState -> Ghc a
176 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
177
178 instance Functor GHCi where
179 fmap = liftM
180
181 instance Applicative GHCi where
182 pure = return
183 (<*>) = ap
184
185 instance Monad GHCi where
186 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
187 return a = GHCi $ \_ -> return a
188
189 getGHCiState :: GHCi GHCiState
190 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
191 setGHCiState :: GHCiState -> GHCi ()
192 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
193 modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
194 modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
195
196 liftGhc :: Ghc a -> GHCi a
197 liftGhc m = GHCi $ \_ -> m
198
199 instance MonadIO GHCi where
200 liftIO = liftGhc . liftIO
201
202 instance HasDynFlags GHCi where
203 getDynFlags = getSessionDynFlags
204
205 instance GhcMonad GHCi where
206 setSession s' = liftGhc $ setSession s'
207 getSession = liftGhc $ getSession
208
209 instance HasDynFlags (InputT GHCi) where
210 getDynFlags = lift getDynFlags
211
212 instance GhcMonad (InputT GHCi) where
213 setSession = lift . setSession
214 getSession = lift getSession
215
216 instance ExceptionMonad GHCi where
217 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
218 gmask f =
219 GHCi $ \s -> gmask $ \io_restore ->
220 let
221 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
222 in
223 unGHCi (f g_restore) s
224
225 instance Haskeline.MonadException Ghc where
226 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
227 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
228 in fmap (flip unGhc s) $ f run'
229
230 instance Haskeline.MonadException GHCi where
231 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
232 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
233 in fmap (flip unGHCi s) $ f run'
234
235 instance ExceptionMonad (InputT GHCi) where
236 gcatch = Haskeline.catch
237 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
238
239 isOptionSet :: GHCiOption -> GHCi Bool
240 isOptionSet opt
241 = do st <- getGHCiState
242 return (opt `elem` options st)
243
244 setOption :: GHCiOption -> GHCi ()
245 setOption opt
246 = do st <- getGHCiState
247 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
248
249 unsetOption :: GHCiOption -> GHCi ()
250 unsetOption opt
251 = do st <- getGHCiState
252 setGHCiState (st{ options = filter (/= opt) (options st) })
253
254 printForUser :: GhcMonad m => SDoc -> m ()
255 printForUser doc = do
256 unqual <- GHC.getPrintUnqual
257 dflags <- getDynFlags
258 liftIO $ Outputable.printForUser dflags stdout unqual doc
259
260 printForUserPartWay :: SDoc -> GHCi ()
261 printForUserPartWay doc = do
262 unqual <- GHC.getPrintUnqual
263 dflags <- getDynFlags
264 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
265
266 -- | Run a single Haskell expression
267 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
268 runStmt expr step = do
269 st <- getGHCiState
270 reifyGHCi $ \x ->
271 withProgName (progname st) $
272 withArgs (args st) $
273 reflectGHCi x $ do
274 GHC.handleSourceError (\e -> do GHC.printException e;
275 return Nothing) $ do
276 r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
277 return (Just r)
278
279 runDecls :: String -> GHCi [GHC.Name]
280 runDecls decls = do
281 st <- getGHCiState
282 reifyGHCi $ \x ->
283 withProgName (progname st) $
284 withArgs (args st) $
285 reflectGHCi x $ do
286 GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
287 GHC.runDeclsWithLocation (progname st) (line_number st) decls
288
289 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
290 resume canLogSpan step = do
291 st <- getGHCiState
292 reifyGHCi $ \x ->
293 withProgName (progname st) $
294 withArgs (args st) $
295 reflectGHCi x $ do
296 GHC.resume canLogSpan step
297
298 -- --------------------------------------------------------------------------
299 -- timing & statistics
300
301 timeIt :: InputT GHCi a -> InputT GHCi a
302 timeIt action
303 = do b <- lift $ isOptionSet ShowTiming
304 if not b
305 then action
306 else do allocs1 <- liftIO $ getAllocations
307 time1 <- liftIO $ getCPUTime
308 a <- action
309 allocs2 <- liftIO $ getAllocations
310 time2 <- liftIO $ getCPUTime
311 dflags <- getDynFlags
312 liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1))
313 (time2 - time1)
314 return a
315
316 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
317 -- defined in ghc/rts/Stats.c
318
319 printTimes :: DynFlags -> Integer -> Integer -> IO ()
320 printTimes dflags allocs psecs
321 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
322 secs_str = showFFloat (Just 2) secs
323 putStrLn (showSDoc dflags (
324 parens (text (secs_str "") <+> text "secs" <> comma <+>
325 text (separateThousands allocs) <+> text "bytes")))
326 where
327 separateThousands n = reverse . sep . reverse . show $ n
328 where sep n'
329 | length n' <= 3 = n'
330 | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
331
332 -----------------------------------------------------------------------------
333 -- reverting CAFs
334
335 revertCAFs :: GHCi ()
336 revertCAFs = do
337 liftIO rts_revertCAFs
338 s <- getGHCiState
339 when (not (ghc_e s)) $ liftIO turnOffBuffering
340 -- Have to turn off buffering again, because we just
341 -- reverted stdout, stderr & stdin to their defaults.
342
343 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
344 -- Make it "safe", just in case
345
346 -----------------------------------------------------------------------------
347 -- To flush buffers for the *interpreted* computation we need
348 -- to refer to *its* stdout/stderr handles
349
350 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
351 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
352 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
353
354 -- After various attempts, I believe this is the least bad way to do
355 -- what we want. We know look up the address of the static stdin,
356 -- stdout, and stderr closures in the loaded base package, and each
357 -- time we need to refer to them we cast the pointer to a Handle.
358 -- This avoids any problems with the CAF having been reverted, because
359 -- we'll always get the current value.
360 --
361 -- The previous attempt that didn't work was to compile an expression
362 -- like "hSetBuffering stdout NoBuffering" into an expression of type
363 -- IO () and run this expression each time we needed it, but the
364 -- problem is that evaluating the expression might cache the contents
365 -- of the Handle rather than referring to it from its static address
366 -- each time. There's no safe workaround for this.
367
368 initInterpBuffering :: Ghc ()
369 initInterpBuffering = do -- make sure these are linked
370 dflags <- GHC.getSessionDynFlags
371 liftIO $ do
372 initDynLinker dflags
373
374 -- ToDo: we should really look up these names properly, but
375 -- it's a fiddle and not all the bits are exposed via the GHC
376 -- interface.
377 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
378 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
379 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
380
381 let f ref (Just ptr) = writeIORef ref ptr
382 f _ Nothing = panic "interactiveUI:setBuffering2"
383 zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
384 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
385
386 flushInterpBuffers :: GHCi ()
387 flushInterpBuffers
388 = liftIO $ do getHandle stdout_ptr >>= hFlush
389 getHandle stderr_ptr >>= hFlush
390
391 turnOffBuffering :: IO ()
392 turnOffBuffering
393 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
394 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
395
396 getHandle :: IORef (Ptr ()) -> IO Handle
397 getHandle ref = do
398 (Ptr addr) <- readIORef ref
399 case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)
400