-
Notifications
You must be signed in to change notification settings - Fork 18
/
SubHalive.hs
378 lines (326 loc) · 14.5 KB
/
SubHalive.hs
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Halive.SubHalive (
module Halive.SubHalive
#if __GLASGOW_HASKELL__ >= 800
, module GHC.LanguageExtensions
#else
, ExtensionFlag(..)
#endif
) where
import GHC
#if __GLASGOW_HASKELL__ >= 800
import GHC.LanguageExtensions
#else
import Module
#endif
import DynFlags
import Exception
import ErrUtils
import HscTypes
import GHC.Paths
import Outputable
import StringBuffer
import PprColour
import qualified Util
-- import Packages
import Linker
#if __GLASGOW_HASKELL__ < 800
import Control.Monad
#endif
import Control.Monad.IO.Class
import Data.IORef
import Data.Time
import Halive.FindPackageDBs
import Control.Concurrent
import System.Signal
import Data.Dynamic
import System.Directory
import System.FilePath
import Data.Time.Clock.POSIX
import qualified Data.Text as Text
data FixDebounce = DebounceFix | NoDebounceFix deriving Eq
data CompliationMode = Interpreted | Compiled deriving Eq
data KeepLibsInMemory = Always | Opportunistic
data GHCSessionConfig = GHCSessionConfig
{ gscFixDebounce :: FixDebounce
, gscImportPaths :: [FilePath]
, gscPackageDBs :: [FilePath]
, gscLibDir :: FilePath
#if __GLASGOW_HASKELL__ >= 800
, gscLanguageExtensions :: [Extension]
, gscNoLanguageExtensions :: [Extension]
#else
, gscLanguageExtensions :: [ExtensionFlag]
, gscNoLanguageExtensions :: [ExtensionFlag]
#endif
, gscCompilationMode :: CompliationMode
, gscStartupFile :: Maybe (FilePath, String)
-- ^ Allow API users to block until a given file is compiled,
-- to work around a bug where the GHC API crashes while
-- loading libraries if the main thread is doing work
-- (possibly due to accessing said libraries in some way)
, gscVerbosity :: Int
, gscMainThreadID :: Maybe ThreadId
, gscKeepLibsInMemory :: KeepLibsInMemory
-- ^ Chooses between keeping the GHC session alive continuously
-- (which uses a lot of memory but makes compilation fast)
-- or disposing of it between compilations
-- (which saves memory but slows compilation)
-- or keeping it around for sequences of compilations
-- (which lies in-between these)
, gscUseColor :: Bool
}
defaultGHCSessionConfig :: GHCSessionConfig
defaultGHCSessionConfig = GHCSessionConfig
{ gscFixDebounce = DebounceFix
, gscImportPaths = []
, gscPackageDBs = []
, gscLanguageExtensions = []
, gscNoLanguageExtensions = []
, gscLibDir = libdir
, gscCompilationMode = Interpreted
, gscStartupFile = Nothing
, gscVerbosity = 0
, gscMainThreadID = Nothing
, gscKeepLibsInMemory = Always
, gscUseColor = False
}
-- Starts up a GHC session and then runs the given action within it
withGHCSession :: ThreadId -> GHCSessionConfig -> Ghc a -> IO a
withGHCSession mainThreadID GHCSessionConfig{..} action = do
-- Work around https://ghc.haskell.org/trac/ghc/ticket/4162
let restoreControlC f = do
liftIO $ installHandler sigINT
(\_signal -> killThread mainThreadID)
f
-- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do
runGhc (Just gscLibDir) . restoreControlC $ do
-- initialFlags <- getSessionDynFlags
-- (newFlags, leftovers, warnings) <- parseDynamicFlagsCmdLine initialFlags [noLoc "-prof"]
-- setSessionDynFlags newFlags
-- liftIO $ print (compilerInfo newFlags)
packageIDs <-
getSessionDynFlags
>>= updateDynFlagsWithGlobalDB
-- If this is a stack project, add its package DBs
>>= updateDynFlagsWithStackDB
-- If there's a sandbox, add its package DB
>>= updateDynFlagsWithCabalSandbox
-- Add passed-in package DBs
>>= (pure . addExtraPkgConfs gscPackageDBs)
-- Make sure we're configured for live-reload
>>= (\d -> pure d
{ hscTarget = if gscCompilationMode == Compiled then HscAsm else HscInterpreted
, optLevel = if gscCompilationMode == Compiled then 1 else 0
, ghcLink = LinkInMemory
, ghcMode = CompManager
, importPaths = gscImportPaths
, objectDir = Just ".halive"
, hiDir = Just ".halive"
, stubDir = Just ".halive"
, dumpDir = Just ".halive"
, verbosity = gscVerbosity
, useColor = if gscUseColor then Util.Always else Util.Never
, canUseColor = gscUseColor
, colScheme = defaultScheme
})
>>= (pure . (`gopt_set` Opt_DiagnosticsShowCaret))
-- turn off the GHCi sandbox
-- since it breaks OpenGL/GUI usage
>>= (pure . (`gopt_unset` Opt_GhciSandbox))
-- Allows us to work in dynamic executables
-- >>= (pure . (if dynamicGhc then addWay' WayDyn else id))
-- >>= (pure . (addWay' WayProf))
-- >>= (pure . (if rtsIsProfiled then addWay' WayProf else id))
-- >>= (pure . (addWay' WayDyn))
-- GHC seems to try to "debounce" compilations within
-- about a half second (i.e., it won't recompile)
-- This fixes that, but probably isn't quite what we want
-- since it will cause extra files to be recompiled...
>>= (pure . (if gscFixDebounce == DebounceFix
then (`gopt_set` Opt_ForceRecomp)
else id))
>>= (pure . flip (foldl xopt_unset) gscNoLanguageExtensions
. flip (foldl xopt_set) gscLanguageExtensions)
-- We must call setSessionDynFlags before calling initPackages or any other GHC API
>>= setSessionDynFlags
-- Initialize the package database and dynamic linker.
-- Explicitly calling these avoids crashes on some of my machines.
#if __GLASGOW_HASKELL__ >= 800
-- (dflags,_pkgs) <- liftIO . initPackages =<< getSessionDynFlags
-- setSessionDynFlags dflags
getSession >>= \hscEnv ->
liftIO $ linkPackages hscEnv packageIDs
liftIO . initDynLinker =<< getSession
#else
getSessionDynFlags >>= \dflags ->
liftIO $ linkPackages dflags packageIDs
liftIO . initDynLinker =<< getSessionDynFlags
#endif
result <- action
-- Unload libraries to keep from leaking memory & overloading the GC
getSession >>= \hscEnv ->
liftIO (unload hscEnv [])
return result
newtype CompiledValue = CompiledValue Dynamic deriving Show
getCompiledValue :: Typeable a => CompiledValue -> Maybe a
getCompiledValue (CompiledValue r) = fromDynamic r
fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime)
fileContentsStringToBuffer fileContents = do
now <- liftIO getCurrentTime
return (stringToStringBuffer fileContents, now)
createTempFile :: MonadIO m => m FilePath
createTempFile = liftIO $ do
tempDir <- getTemporaryDirectory
now <- show . diffTimeToPicoseconds . realToFrac <$> getPOSIXTime
let tempFile = tempDir </> "halive_" ++ now <.> "hs"
writeFile tempFile ""
return tempFile
-- | Takes a filename, optionally its contents, and a list of expressions.
-- Returns a list of errors or a list of Dynamic compiled values
recompileExpressionsInFile :: FilePath
-> Maybe String
-> [String]
-> Ghc (Either String [CompiledValue])
recompileExpressionsInFile fileName mFileContents expressions =
catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do
-- Set up an error accumulator
errorsRef <- liftIO (newIORef "")
_ <- getSessionDynFlags >>=
\dflags -> setSessionDynFlags dflags
{ log_action = logHandler errorsRef }
mFileContentsBuffer <- mapM fileContentsStringToBuffer mFileContents
-- Set the target
(tempFileName, target) <- case fileName of
-- We'd like to just use a Module name for the target,
-- but load/depanal fails with "Foo is a package module"
-- We use a blank temp file as a workaround.
"" -> do
tempFileName <- createTempFile
(tempFileName,) <$> guessTarget' tempFileName
other -> ("",) <$> guessTarget' other
-- logIO "Setting targets..."
setTargets [target { targetContents = mFileContentsBuffer }]
-- Reload the main target
-- logIO "Loading..."
loadSuccess <- load LoadAllTargets
if succeeded loadSuccess
then do
-- logIO "Analyzing deps..."
-- Get the dependencies of the main target (and update the session with them)
graph <- depanal [] False
#if __GLASGOW_HASKELL__ >= 804
let modSummaries = mgModSummaries graph
#else
let modSummaries = graph
#endif
-- Load the dependencies of the main target
setContext
(IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries)
-- Compile the expressions and return the results
results <- mapM dynCompileExpr expressions
return (Right (CompiledValue <$> results))
else do
-- Extract the errors from the accumulator
errors <- liftIO (readIORef errorsRef)
-- Strip out the temp file name when using anonymous code
let cleanErrors = if null tempFileName then errors
else Text.unpack $
Text.replace
(Text.pack tempFileName)
"<anonymous code>"
(Text.pack errors)
return (Left cleanErrors)
-- Prepend a '*' to prevent GHC from trying to load from any previously compiled object files
-- see http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile
guessTarget' :: GhcMonad m => String -> m Target
guessTarget' fileName = guessTarget ('*':fileName) Nothing
catchExceptions :: ExceptionMonad m => m (Either String a) -> m (Either String a)
catchExceptions a = gcatch a
(\(_x :: SomeException) -> do
liftIO (putStrLn ("Caught exception during recompileExpressionInFile: " ++ show _x))
return (Left (show _x))
)
-- Adapted from
-- https://hackage.haskell.org/package/ghc-8.2.1/docs/src/DynFlags.html#defaultLogAction
logHandler :: IORef String -> LogAction
logHandler errorIORef dflags reason severity srcSpan style msg
= case severity of
SevOutput -> printOut msg style
SevDump -> printOut (msg $$ blankLine) style
SevInteractive -> putStrSDoc msg style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do -- otherwise (i.e. SevError or SevWarning)
caretDiagnostic <-
if gopt Opt_DiagnosticsShowCaret dflags
then getCaretDiagnostic severity srcSpan
else pure empty
writeToErrorIORef (message $+$ caretDiagnostic)
(setStyleColoured True style)
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
-- each unicode char.
where printOut = writeToErrorIORef
printErrs = writeToErrorIORef
putStrSDoc = writeToErrorIORef
-- Pretty print the warning flag, if any (#10752)
message = mkLocMessageAnn Nothing severity srcSpan msg
writeToErrorIORef message style =
modifyIORef' errorIORef
(++ ('\n':renderWithStyle dflags message style))
-- logHandler :: IORef String -> LogAction
-- #if __GLASGOW_HASKELL__ >= 800
-- logHandler ref dflags _warnReason severity srcSpan style msg =
-- #else
-- logHandler ref dflags severity srcSpan style msg =
-- #endif
-- caretDiagnostic <- getCaretDiagnostic dflags srcSpan
-- let cntx = initSDocContext dflags style
-- locMsg = mkLocMessage severity srcSpan msg
-- messageWithLocation = show (runSDoc locMsg cntx)
-- messageOther = show (runSDoc msg cntx)
-- renderWithStyle dflags (msg $+$ caretDiagnostic)
-- (setStyleColoured True style)
-- case severity of
-- SevError -> modifyIORef' ref (++ ('\n':messageWithLocation))
-- SevFatal -> modifyIORef' ref (++ ('\n':messageWithLocation))
-- SevWarning -> modifyIORef' ref (++ ('\n':messageWithLocation))
-- _ -> do
-- putStr messageOther
-- return () -- ignore the rest
-- A helper from interactive-diagrams to print out GHC API values,
-- useful while debugging the API.
-- | Outputs any value that can be pretty-printed using the default style
output :: (GhcMonad m, Outputable a) => a -> m ()
output a = do
dfs <- getSessionDynFlags
let style = defaultUserStyle dfs
let cntx = initSDocContext dfs style
liftIO $ print $ runSDoc (ppr a) cntx
-- NOTE: handleSourceError (which calls gatherErrors above)
-- doesn't actually seem to do anything, so we use
-- the IORef + log_action solution instead.
-- The API docs claim 'load' should
-- throw SourceErrors but it doesn't afaict.
gatherErrors :: GhcMonad m => SourceError -> m String
gatherErrors sourceError = do
printException sourceError
dflags <- getSessionDynFlags
let style = mkUserStyle dflags neverQualify AllTheWay
errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError)
errorStrings = map (showSDocForUser dflags neverQualify) errorSDocs
return (concat errorStrings)
--pkgConfRefToString = \case
-- GlobalPkgConf -> "GlobalPkgConf"
-- UserPkgConf -> "UserPkgConf"
-- PkgConfFile file -> "PkgConfFile " ++ show file
--extraPkgConfsToString dflags = show $ map pkgConfRefToString $ extraPkgConfs dflags $ []
logIO :: MonadIO m => String -> m ()
logIO = liftIO . putStrLn