| ... |
... |
@@ -7,6 +7,8 @@ |
|
7
|
7
|
-- (c) The University of Glasgow 2005
|
|
8
|
8
|
--
|
|
9
|
9
|
-----------------------------------------------------------------------------
|
|
|
10
|
+{-# LANGUAGE DerivingVia #-}
|
|
|
11
|
+{-# LANGUAGE RecordWildCards #-}
|
|
10
|
12
|
|
|
11
|
13
|
module GHC.Driver.MakeFile
|
|
12
|
14
|
( doMkDependHS
|
| ... |
... |
@@ -16,9 +18,10 @@ where |
|
16
|
18
|
|
|
17
|
19
|
import GHC.Prelude
|
|
18
|
20
|
|
|
19
|
|
-
|
|
20
|
21
|
import qualified GHC
|
|
21
|
22
|
|
|
|
23
|
+import GHC.Data.Bag (listToBag)
|
|
|
24
|
+import GHC.Data.FastString
|
|
22
|
25
|
import GHC.Data.Graph.Directed (SCC (..))
|
|
23
|
26
|
import GHC.Data.OsPath (unsafeDecodeUtf, unsafeEncodeUtf)
|
|
24
|
27
|
|
| ... |
... |
@@ -35,12 +38,12 @@ import GHC.Driver.Session |
|
35
|
38
|
import GHC.Iface.Errors.Types
|
|
36
|
39
|
import GHC.Iface.Load (cannotFindModule)
|
|
37
|
40
|
|
|
38
|
|
-import qualified GHC.SysTools as SysTools
|
|
|
41
|
+import GHC.SysTools qualified as SysTools
|
|
39
|
42
|
import GHC.Types.PkgQual
|
|
40
|
43
|
import GHC.Types.SourceError
|
|
41
|
44
|
import GHC.Types.SrcLoc
|
|
42
|
45
|
import GHC.Types.Unique.Set (UniqSet)
|
|
43
|
|
-import qualified GHC.Types.Unique.Set as UniqSet
|
|
|
46
|
+import GHC.Types.Unique.Set qualified as UniqSet
|
|
44
|
47
|
import GHC.Types.UnresolvedImport
|
|
45
|
48
|
|
|
46
|
49
|
import GHC.Unit.Finder
|
| ... |
... |
@@ -52,23 +55,27 @@ import GHC.Unit.State (lookupUnitId) |
|
52
|
55
|
|
|
53
|
56
|
import GHC.Utils.Error
|
|
54
|
57
|
import GHC.Utils.Exception
|
|
|
58
|
+import GHC.Utils.Json
|
|
55
|
59
|
import GHC.Utils.Logger
|
|
56
|
60
|
import GHC.Utils.Misc
|
|
57
|
61
|
import GHC.Utils.Outputable
|
|
58
|
62
|
import GHC.Utils.Panic
|
|
59
|
63
|
import GHC.Utils.TmpFs
|
|
60
|
64
|
|
|
61
|
|
-import System.Directory
|
|
62
|
|
-import System.FilePath
|
|
63
|
|
-import System.IO
|
|
64
|
|
-import System.IO.Error (isEOFError)
|
|
65
|
65
|
import Control.Monad (when)
|
|
66
|
66
|
import Data.Either
|
|
67
|
67
|
import Data.Foldable (traverse_)
|
|
68
|
68
|
import Data.IORef
|
|
69
|
69
|
import Data.List (partition)
|
|
|
70
|
+import Data.Map.Strict qualified as Map
|
|
70
|
71
|
import Data.Maybe (isJust, isNothing)
|
|
|
72
|
+import Data.Semigroup qualified as Semigroup
|
|
71
|
73
|
import Data.Set qualified as Set
|
|
|
74
|
+import GHC.Generics (Generic, Generically (..))
|
|
|
75
|
+import System.Directory
|
|
|
76
|
+import System.FilePath
|
|
|
77
|
+import System.IO
|
|
|
78
|
+import System.IO.Error (isEOFError)
|
|
72
|
79
|
|
|
73
|
80
|
-----------------------------------------------------------------
|
|
74
|
81
|
--
|
| ... |
... |
@@ -117,7 +124,15 @@ doMkDependModuleGraph dflags module_graph = do |
|
117
|
124
|
excl_mods = depExcludeMods dflags
|
|
118
|
125
|
|
|
119
|
126
|
root <- liftIO getCurrentDirectory
|
|
120
|
|
- let dep_writer = initFileDepWriter logger root tmpfs dflags
|
|
|
127
|
+ let
|
|
|
128
|
+ dep_writers =
|
|
|
129
|
+ concat
|
|
|
130
|
+ [ [ SomeDependencyWriter $ initFileDepWriter logger root tmpfs dflags
|
|
|
131
|
+ ]
|
|
|
132
|
+ , [ SomeDependencyWriter $ initJsonDepWriter json_output dflags
|
|
|
133
|
+ | Just json_output <- [depJson dflags]
|
|
|
134
|
+ ]
|
|
|
135
|
+ ]
|
|
121
|
136
|
|
|
122
|
137
|
|
|
123
|
138
|
let sorted = GHC.topSortModuleGraph False module_graph Nothing
|
| ... |
... |
@@ -125,12 +140,25 @@ doMkDependModuleGraph dflags module_graph = do |
|
125
|
140
|
liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
|
|
126
|
141
|
|
|
127
|
142
|
liftIO $ bracket
|
|
128
|
|
- (dw_beginWriter dep_writer)
|
|
|
143
|
+ (do
|
|
|
144
|
+ traverse
|
|
|
145
|
+ (\ (SomeDependencyWriter dep_writer) -> do
|
|
|
146
|
+ backend <- dw_beginWriter dep_writer
|
|
|
147
|
+ pure (SomeDependencyWriter2 (dep_writer, backend))
|
|
|
148
|
+ )
|
|
|
149
|
+ dep_writers
|
|
|
150
|
+ )
|
|
129
|
151
|
-- Tidy up
|
|
130
|
|
- (dw_endWriter dep_writer)
|
|
131
|
|
- ( \ files -> do
|
|
|
152
|
+ (\ writers -> do
|
|
|
153
|
+ traverse
|
|
|
154
|
+ ( \(SomeDependencyWriter2 (writer, backend)) ->
|
|
|
155
|
+ dw_endWriter writer backend
|
|
|
156
|
+ )
|
|
|
157
|
+ writers
|
|
|
158
|
+ )
|
|
|
159
|
+ ( \ backends -> do
|
|
132
|
160
|
-- Process them one by one, dumping results and complaining about cycles
|
|
133
|
|
- mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) [(dep_writer, files)]) sorted
|
|
|
161
|
+ mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) backends) sorted
|
|
134
|
162
|
|
|
135
|
163
|
-- If -ddump-mod-cycles, show cycles in the module graph
|
|
136
|
164
|
liftIO $ dumpModCycles logger module_graph
|
| ... |
... |
@@ -147,28 +175,41 @@ doMkDependModuleGraph dflags module_graph = do |
|
147
|
175
|
-- Types abstracting over the output
|
|
148
|
176
|
--------------------------------------------------------------------------------
|
|
149
|
177
|
|
|
150
|
|
-data DepNode
|
|
151
|
|
- = DepNode {
|
|
152
|
|
- dn_mod :: Module,
|
|
153
|
|
- dn_src :: FilePath,
|
|
154
|
|
- dn_obj :: FilePath,
|
|
155
|
|
- dn_hi :: FilePath,
|
|
156
|
|
- dn_boot :: IsBootInterface,
|
|
157
|
|
- dn_options :: [String]
|
|
|
178
|
+data DepNode =
|
|
|
179
|
+ DepNode
|
|
|
180
|
+ { dn_mod :: Module
|
|
|
181
|
+ , dn_src :: FilePath
|
|
|
182
|
+ , dn_obj :: FilePath
|
|
|
183
|
+ , dn_hi :: FilePath
|
|
|
184
|
+ , dn_boot :: IsBootInterface
|
|
|
185
|
+ , dn_preprocessor :: PreprocessorInfo
|
|
|
186
|
+ }
|
|
|
187
|
+
|
|
|
188
|
+data PreprocessorInfo =
|
|
|
189
|
+ PreprocessorInfo
|
|
|
190
|
+ { pi_options :: [String]
|
|
158
|
191
|
-- ^ module level @OPTIONS_GHC@ pragma contents
|
|
|
192
|
+ , pi_processor :: Maybe FilePath
|
|
159
|
193
|
}
|
|
160
|
194
|
|
|
161
|
195
|
data Dep
|
|
162
|
|
- = DepHi {
|
|
163
|
|
- dep_mod :: Module,
|
|
164
|
|
- dep_path :: FilePath,
|
|
165
|
|
- dep_unit :: Maybe UnitInfo,
|
|
166
|
|
- dep_local :: Bool,
|
|
167
|
|
- dep_boot :: IsBootInterface
|
|
|
196
|
+ = DepHi
|
|
|
197
|
+ { dep_mod_name :: ModuleName
|
|
|
198
|
+ , dep_path :: FilePath
|
|
|
199
|
+ , dep_unit :: Maybe UnitInfo
|
|
|
200
|
+ , dep_local :: Bool
|
|
|
201
|
+ , dep_boot :: IsBootInterface
|
|
|
202
|
+ }
|
|
|
203
|
+ | DepCpp
|
|
|
204
|
+ { dep_path :: FilePath
|
|
168
|
205
|
}
|
|
169
|
|
- | DepCpp {
|
|
170
|
|
- dep_path :: FilePath
|
|
171
|
|
- }
|
|
|
206
|
+
|
|
|
207
|
+
|
|
|
208
|
+data SomeDependencyWriter =
|
|
|
209
|
+ forall backend . SomeDependencyWriter (DependencyWriter backend)
|
|
|
210
|
+
|
|
|
211
|
+data SomeDependencyWriter2 =
|
|
|
212
|
+ forall backend . SomeDependencyWriter2 ((DependencyWriter backend, backend))
|
|
172
|
213
|
|
|
173
|
214
|
data DependencyWriter backend = DependencyWriter
|
|
174
|
215
|
{ dw_beginWriter :: IO backend
|
| ... |
... |
@@ -185,7 +226,7 @@ data DependencyWriter backend = DependencyWriter |
|
185
|
226
|
processDeps :: DynFlags
|
|
186
|
227
|
-> HscEnv
|
|
187
|
228
|
-> UniqSet ModuleName -- ^ Excludes
|
|
188
|
|
- -> [(DependencyWriter backend, backend)]
|
|
|
229
|
+ -> [SomeDependencyWriter2]
|
|
189
|
230
|
-> SCC ModuleGraphNode
|
|
190
|
231
|
-> IO ()
|
|
191
|
232
|
-- Write suitable dependencies to handle
|
| ... |
... |
@@ -221,27 +262,40 @@ processDeps _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) |
|
221
|
262
|
|
|
222
|
263
|
processDeps dflags hsc_env excl_mods backends (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do
|
|
223
|
264
|
pp <- preprocessor
|
|
224
|
|
- let dep_node = mkDepNode (maybe [] snd pp)
|
|
225
|
|
- deps <- fmap concat $ sequence $
|
|
226
|
|
- [cpp_deps | depIncludeCppDeps dflags] ++ [
|
|
227
|
|
- import_deps IsBoot (ms_srcimps node),
|
|
228
|
|
- import_deps NotBoot (ms_imps node)
|
|
229
|
|
- ]
|
|
|
265
|
+ let dep_node = mkDepNode pp
|
|
|
266
|
+
|
|
|
267
|
+ let
|
|
|
268
|
+ find_deps = do
|
|
|
269
|
+ cpp_deps <- find_cpp_deps
|
|
|
270
|
+ imp_deps <- find_import_deps (ms_imps node)
|
|
|
271
|
+ pure $ map Right cpp_deps ++ imp_deps
|
|
|
272
|
+
|
|
|
273
|
+ (missing_dep_errs, deps) <- partitionEithers <$> find_deps
|
|
|
274
|
+
|
|
|
275
|
+ if null missing_dep_errs
|
|
|
276
|
+ then do
|
|
|
277
|
+ traverse_
|
|
|
278
|
+ (\ (SomeDependencyWriter2 (writer, backend)) ->
|
|
|
279
|
+ dw_writeDependency writer backend dep_node deps
|
|
|
280
|
+ )
|
|
|
281
|
+ backends
|
|
|
282
|
+ else do
|
|
|
283
|
+ let sec = initSourceErrorContext (hsc_dflags hsc_env)
|
|
|
284
|
+ throwErrors sec (mkMessages (listToBag missing_dep_errs))
|
|
230
|
285
|
|
|
231
|
|
- traverse_ (\ (writer, backend) -> dw_writeDependency writer backend dep_node deps) backends
|
|
232
|
286
|
where
|
|
233
|
287
|
src_file = msHsFilePath node
|
|
234
|
|
- mkDepNode opts =
|
|
|
288
|
+ mkDepNode preproc =
|
|
235
|
289
|
DepNode {
|
|
236
|
290
|
dn_mod = ms_mod node,
|
|
237
|
291
|
dn_src = src_file,
|
|
238
|
292
|
dn_obj = msObjFilePath node,
|
|
239
|
293
|
dn_hi = msHiFilePath node,
|
|
240
|
294
|
dn_boot = isBootSummary node,
|
|
241
|
|
- dn_options = opts
|
|
|
295
|
+ dn_preprocessor = preproc
|
|
242
|
296
|
}
|
|
243
|
297
|
|
|
244
|
|
- preprocessor :: IO (Maybe (String, [String]))
|
|
|
298
|
+ preprocessor :: IO PreprocessorInfo
|
|
245
|
299
|
preprocessor
|
|
246
|
300
|
| Just src <- ml_hs_file (ms_location node)
|
|
247
|
301
|
= runPipeline (hsc_hooks hsc_env) $ do
|
| ... |
... |
@@ -252,15 +306,23 @@ processDeps dflags hsc_env excl_mods backends (AcyclicSCC (ModuleNode _ (ModuleN |
|
252
|
306
|
unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env src) else pure src
|
|
253
|
307
|
(dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (hsc_dflags hsc_env) unlit_fn)
|
|
254
|
308
|
let pp = pgm_F dflags1
|
|
255
|
|
- pure (if null pp then global_preprocessor else Just (pp, opts))
|
|
|
309
|
+ pure
|
|
|
310
|
+ PreprocessorInfo
|
|
|
311
|
+ { pi_processor = if null pp then global_preprocessor else Just pp
|
|
|
312
|
+ , pi_options = opts
|
|
|
313
|
+ }
|
|
256
|
314
|
| otherwise
|
|
257
|
|
- = pure global_preprocessor
|
|
|
315
|
+ = pure
|
|
|
316
|
+ PreprocessorInfo
|
|
|
317
|
+ { pi_processor = global_preprocessor
|
|
|
318
|
+ , pi_options = []
|
|
|
319
|
+ }
|
|
258
|
320
|
|
|
259
|
|
- global_preprocessor :: Maybe (String, [String])
|
|
|
321
|
+ global_preprocessor :: Maybe String
|
|
260
|
322
|
global_preprocessor
|
|
261
|
323
|
| let pp = pgm_F dflags
|
|
262
|
324
|
, not (null pp)
|
|
263
|
|
- = Just (pp, [])
|
|
|
325
|
+ = Just pp
|
|
264
|
326
|
| otherwise
|
|
265
|
327
|
= Nothing
|
|
266
|
328
|
|
| ... |
... |
@@ -269,53 +331,49 @@ processDeps dflags hsc_env excl_mods backends (AcyclicSCC (ModuleNode _ (ModuleN |
|
269
|
331
|
-- comment lines left by the preprocessor.
|
|
270
|
332
|
-- Note that GHC.parseModule may throw an exception if the module
|
|
271
|
333
|
-- fails to parse, which may not be desirable (see #16616).
|
|
272
|
|
- cpp_deps :: IO [Dep]
|
|
273
|
|
- cpp_deps = do
|
|
|
334
|
+ find_cpp_deps :: IO [Dep]
|
|
|
335
|
+ find_cpp_deps = do
|
|
274
|
336
|
session <- Session <$> newIORef hsc_env
|
|
275
|
337
|
parsedMod <- reflectGhc (GHC.parseModule node) session
|
|
276
|
338
|
pure (DepCpp <$> GHC.pm_extra_src_files parsedMod)
|
|
277
|
339
|
|
|
278
|
340
|
-- Emit a dependency for each import
|
|
279
|
|
- import_deps :: IsBootInterface -> [UnresolvedImport PkgQual] -> IO [Dep]
|
|
280
|
|
- import_deps is_boot idecls =
|
|
281
|
|
- sequence [
|
|
282
|
|
- findDependency hsc_env loc mb_pkg mod is_boot
|
|
|
341
|
+ find_import_deps :: [UnresolvedImport PkgQual] -> IO [Either (MsgEnvelope GhcMessage) Dep]
|
|
|
342
|
+ find_import_deps idecls =
|
|
|
343
|
+ sequence
|
|
|
344
|
+ [ findDependency hsc_env decl
|
|
283
|
345
|
| decl <- idecls
|
|
284
|
|
- , let mb_pkg = ui_pkg_qual decl
|
|
285
|
|
- , let L loc mod = ui_mod_name decl
|
|
286
|
|
- , mod `UniqSet.elementOfUniqSet` excl_mods
|
|
|
346
|
+ , let L _loc mod = ui_mod_name decl
|
|
|
347
|
+ , not (mod `UniqSet.elementOfUniqSet` excl_mods)
|
|
287
|
348
|
]
|
|
288
|
349
|
|
|
289
|
350
|
|
|
290
|
351
|
findDependency :: HscEnv
|
|
291
|
|
- -> SrcSpan
|
|
292
|
|
- -> PkgQual -- package qualifier, if any
|
|
293
|
|
- -> ModuleName -- Imported module
|
|
294
|
|
- -> IsBootInterface -- Source import
|
|
295
|
|
- -> IO Dep
|
|
296
|
|
-findDependency hsc_env srcloc pkg imp dep_boot = do
|
|
|
352
|
+ -> UnresolvedImport PkgQual -- The import to find
|
|
|
353
|
+ -> IO (Either (MsgEnvelope GhcMessage) Dep) -- Interface file
|
|
|
354
|
+findDependency hsc_env imp = do
|
|
297
|
355
|
-- Find the module; this will be fast because
|
|
298
|
356
|
-- we've done it once during downsweep
|
|
299
|
|
- findImportedModule hsc_env LookupUser imp pkg >>= \case
|
|
|
357
|
+ resolveImport hsc_env imp >>= \case
|
|
300
|
358
|
Found loc dep_mod ->
|
|
301
|
|
- pure DepHi {
|
|
302
|
|
- dep_mod,
|
|
303
|
|
- dep_path = ml_hi_file loc,
|
|
304
|
|
- dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod),
|
|
305
|
|
- dep_local,
|
|
306
|
|
- dep_boot
|
|
307
|
|
- }
|
|
308
|
|
- where
|
|
309
|
|
- dep_local = isJust (ml_hs_file loc)
|
|
|
359
|
+ pure $ Right
|
|
|
360
|
+ DepHi
|
|
|
361
|
+ { dep_mod_name = mod_name
|
|
|
362
|
+ , dep_path = ml_hi_file loc
|
|
|
363
|
+ , dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod)
|
|
|
364
|
+ , dep_local = isJust (ml_hs_file loc)
|
|
|
365
|
+ , dep_boot = is_boot
|
|
|
366
|
+ }
|
|
310
|
367
|
|
|
311
|
368
|
fail ->
|
|
312
|
|
- throwOneError
|
|
313
|
|
- (initSourceErrorContext (hsc_dflags hsc_env)) $
|
|
314
|
|
- mkPlainErrorMsgEnvelope srcloc $
|
|
315
|
|
- GhcDriverMessage $
|
|
316
|
|
- DriverInterfaceError $
|
|
317
|
|
- Can'tFindInterface (cannotFindModule hsc_env imp fail) $
|
|
318
|
|
- LookingForModule imp dep_boot
|
|
|
369
|
+ return $
|
|
|
370
|
+ Left $
|
|
|
371
|
+ mkPlainErrorMsgEnvelope srcloc $
|
|
|
372
|
+ GhcDriverMessage $ DriverInterfaceError $
|
|
|
373
|
+ (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot))
|
|
|
374
|
+ where
|
|
|
375
|
+ L srcloc mod_name = ui_mod_name imp
|
|
|
376
|
+ is_boot = ui_boot imp
|
|
319
|
377
|
|
|
320
|
378
|
|
|
321
|
379
|
-----------------------------------------------------------------
|
| ... |
... |
@@ -467,11 +525,8 @@ insertSuffixes file_name extras |
|
467
|
525
|
|
|
468
|
526
|
|
|
469
|
527
|
-----------------------------------------------------------------
|
|
470
|
|
---
|
|
471
|
|
--- endMkDependHs
|
|
472
|
|
--- Complete the makefile, close the tmp file etc
|
|
473
|
|
---
|
|
474
|
|
------------------------------------------------------------------
|
|
|
528
|
+-- endMkDependHs
|
|
|
529
|
+-- Complete the makefile, close the tmp file etc
|
|
475
|
530
|
|
|
476
|
531
|
endMkDependHS :: Logger -> MkDepFiles -> IO ()
|
|
477
|
532
|
|
| ... |
... |
@@ -500,6 +555,183 @@ endMkDependHS logger |
|
500
|
555
|
showPass logger "Installing new makefile"
|
|
501
|
556
|
SysTools.copyFile tmp_file makefile
|
|
502
|
557
|
|
|
|
558
|
+-----------------------------------------------------------------
|
|
|
559
|
+--
|
|
|
560
|
+-- JSON MkDepends output
|
|
|
561
|
+--
|
|
|
562
|
+-----------------------------------------------------------------
|
|
|
563
|
+
|
|
|
564
|
+initJsonDepWriter :: FilePath -> DynFlags -> DependencyWriter (JsonOutput DepJson)
|
|
|
565
|
+initJsonDepWriter output dflags = DependencyWriter
|
|
|
566
|
+ { dw_beginWriter = do
|
|
|
567
|
+ mkJsonOutput output initDepJson
|
|
|
568
|
+ , dw_writeDependency = \ backend node deps -> do
|
|
|
569
|
+ updateJson backend (updateDepJson (depIncludePkgDeps dflags) node deps)
|
|
|
570
|
+ , dw_endWriter =
|
|
|
571
|
+ writeJsonOutput
|
|
|
572
|
+ }
|
|
|
573
|
+
|
|
|
574
|
+--------------------------------------------------------------------------------
|
|
|
575
|
+-- Output interface for json dumps
|
|
|
576
|
+
|
|
|
577
|
+-- | Resources for a json dump option, used in "GHC.Driver.MakeFile".
|
|
|
578
|
+-- The flag @-dep-json@ add an additional output target for dependency
|
|
|
579
|
+-- diagnostics.
|
|
|
580
|
+data JsonOutput a =
|
|
|
581
|
+ JsonOutput {
|
|
|
582
|
+ -- | This ref is updated in @processDeps@ incrementally, using a
|
|
|
583
|
+ -- flag-specific type.
|
|
|
584
|
+ json_ref :: IORef a,
|
|
|
585
|
+
|
|
|
586
|
+ -- | The output file path specified as argument to the flag.
|
|
|
587
|
+ json_path :: FilePath
|
|
|
588
|
+ }
|
|
|
589
|
+
|
|
|
590
|
+-- | TODO: @fendor
|
|
|
591
|
+mkJsonOutput ::
|
|
|
592
|
+ FilePath ->
|
|
|
593
|
+ IO (IORef a) ->
|
|
|
594
|
+ IO (JsonOutput a)
|
|
|
595
|
+mkJsonOutput json_path mk_ref = do
|
|
|
596
|
+ json_ref <- mk_ref
|
|
|
597
|
+ pure JsonOutput {json_ref, json_path}
|
|
|
598
|
+
|
|
|
599
|
+-- | Update the dump data in 'json_ref' if the output target is present.
|
|
|
600
|
+updateJson :: JsonOutput a -> (a -> a) -> IO ()
|
|
|
601
|
+updateJson JsonOutput {json_ref} f = modifyIORef' json_ref f
|
|
|
602
|
+
|
|
|
603
|
+-- | Write a json object to the flag-dependent file if the output target is
|
|
|
604
|
+-- present.
|
|
|
605
|
+writeJsonOutput ::
|
|
|
606
|
+ ToJson a =>
|
|
|
607
|
+ JsonOutput a ->
|
|
|
608
|
+ IO ()
|
|
|
609
|
+writeJsonOutput JsonOutput {json_ref, json_path} = do
|
|
|
610
|
+ payload <- readIORef json_ref
|
|
|
611
|
+ writeJsonFile payload json_path
|
|
|
612
|
+
|
|
|
613
|
+--------------------------------------------------------------------------------
|
|
|
614
|
+-- Output helpers
|
|
|
615
|
+
|
|
|
616
|
+writeJsonFile :: ToJson a => a -> FilePath -> IO ()
|
|
|
617
|
+writeJsonFile doc p = do
|
|
|
618
|
+ withAtomicRename p
|
|
|
619
|
+ $ \tmp -> writeFile tmp $ showSDocUnsafe $ renderJSON $ json doc
|
|
|
620
|
+
|
|
|
621
|
+--------------------------------------------------------------------------------
|
|
|
622
|
+-- Payload for -dep-json
|
|
|
623
|
+
|
|
|
624
|
+newtype PackageDeps =
|
|
|
625
|
+ PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName))
|
|
|
626
|
+ deriving newtype (Monoid)
|
|
|
627
|
+
|
|
|
628
|
+newtype DPackageId = DPackageId PackageId
|
|
|
629
|
+ deriving newtype (Eq)
|
|
|
630
|
+
|
|
|
631
|
+instance Ord DPackageId where
|
|
|
632
|
+ DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2
|
|
|
633
|
+
|
|
|
634
|
+instance Semigroup PackageDeps where
|
|
|
635
|
+ PackageDeps l <> PackageDeps r = PackageDeps (Map.unionWith (Semigroup.<>) l r)
|
|
|
636
|
+
|
|
|
637
|
+data Deps =
|
|
|
638
|
+ Deps {
|
|
|
639
|
+ sources :: Set.Set FilePath,
|
|
|
640
|
+ modules :: (Set.Set ModuleName, Set.Set ModuleName),
|
|
|
641
|
+ packages :: PackageDeps,
|
|
|
642
|
+ cpp :: Set.Set FilePath,
|
|
|
643
|
+ options :: [String],
|
|
|
644
|
+ preprocessor :: Maybe FilePath
|
|
|
645
|
+ }
|
|
|
646
|
+ deriving stock (Generic)
|
|
|
647
|
+ deriving (Semigroup, Monoid) via (Generically Deps)
|
|
|
648
|
+
|
|
|
649
|
+newtype DepJson = DepJson (Map.Map ModuleName Deps)
|
|
|
650
|
+
|
|
|
651
|
+instance ToJson DepJson where
|
|
|
652
|
+ json (DepJson m) =
|
|
|
653
|
+ JSObject [
|
|
|
654
|
+ (moduleNameString target, JSObject [
|
|
|
655
|
+ ("sources", array sources normalise),
|
|
|
656
|
+ ("modules", array (fst modules) moduleNameString),
|
|
|
657
|
+ ("modules-boot", array (snd modules) moduleNameString),
|
|
|
658
|
+ ("packages",
|
|
|
659
|
+ JSArray
|
|
|
660
|
+ [ package name unit_id package_id mods
|
|
|
661
|
+ | ((name, unit_id, dpkd_id), mods) <- Map.toList packages
|
|
|
662
|
+ , let DPackageId package_id = dpkd_id
|
|
|
663
|
+ ]
|
|
|
664
|
+ ),
|
|
|
665
|
+ ("cpp", array cpp id),
|
|
|
666
|
+ ("options", JSArray $ map JSString options),
|
|
|
667
|
+ ("preprocessor", maybe JSNull JSString preprocessor)
|
|
|
668
|
+ ])
|
|
|
669
|
+ | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m
|
|
|
670
|
+ ]
|
|
|
671
|
+ where
|
|
|
672
|
+ package name unit_id (PackageId package_id) mods =
|
|
|
673
|
+ JSObject [
|
|
|
674
|
+ ("id", JSString (unitIdString unit_id)),
|
|
|
675
|
+ ("name", JSString name),
|
|
|
676
|
+ ("package-id", JSString (unpackFS package_id)),
|
|
|
677
|
+ ("modules", array mods moduleNameString)
|
|
|
678
|
+ ]
|
|
|
679
|
+
|
|
|
680
|
+ array values render = JSArray (fmap (JSString . render) (Set.toList values))
|
|
|
681
|
+
|
|
|
682
|
+initDepJson :: IO (IORef DepJson)
|
|
|
683
|
+initDepJson = newIORef $ DepJson Map.empty
|
|
|
684
|
+
|
|
|
685
|
+insertDepJson :: [ModuleName] -> Deps -> DepJson -> DepJson
|
|
|
686
|
+insertDepJson targets dep (DepJson m0) =
|
|
|
687
|
+ DepJson
|
|
|
688
|
+ $ foldl'
|
|
|
689
|
+ ( \acc target ->
|
|
|
690
|
+ Map.insertWith
|
|
|
691
|
+ (Semigroup.<>)
|
|
|
692
|
+ target
|
|
|
693
|
+ dep
|
|
|
694
|
+ acc
|
|
|
695
|
+ )
|
|
|
696
|
+ m0
|
|
|
697
|
+ targets
|
|
|
698
|
+
|
|
|
699
|
+updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
|
|
|
700
|
+updateDepJson include_pkgs DepNode {..} deps =
|
|
|
701
|
+ insertDepJson [moduleName dn_mod] payload
|
|
|
702
|
+ where
|
|
|
703
|
+ payload = node_data Semigroup.<> foldMap dep deps
|
|
|
704
|
+
|
|
|
705
|
+ node_data =
|
|
|
706
|
+ mempty {
|
|
|
707
|
+ sources = Set.singleton dn_src,
|
|
|
708
|
+ preprocessor = pi_processor dn_preprocessor,
|
|
|
709
|
+ options = pi_options dn_preprocessor
|
|
|
710
|
+ }
|
|
|
711
|
+
|
|
|
712
|
+ dep = \case
|
|
|
713
|
+ DepHi {dep_mod_name, dep_local, dep_unit, dep_boot}
|
|
|
714
|
+ | dep_local
|
|
|
715
|
+ , let set = Set.singleton dep_mod_name
|
|
|
716
|
+ value | IsBoot <- dep_boot = (Set.empty, set)
|
|
|
717
|
+ | otherwise = (set, Set.empty)
|
|
|
718
|
+ -> mempty {modules = value}
|
|
|
719
|
+
|
|
|
720
|
+ | include_pkgs
|
|
|
721
|
+ , Just unit <- dep_unit
|
|
|
722
|
+ , let PackageName nameFS = unitPackageName unit
|
|
|
723
|
+ name = unpackFS nameFS
|
|
|
724
|
+ withLibName (PackageName c) = name ++ ":" ++ unpackFS c
|
|
|
725
|
+ lname = maybe name withLibName (unitComponentName unit)
|
|
|
726
|
+ key = (lname, unitId unit, DPackageId $ unitPackageId unit)
|
|
|
727
|
+ -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton dep_mod_name))}
|
|
|
728
|
+
|
|
|
729
|
+ | otherwise
|
|
|
730
|
+ -> mempty
|
|
|
731
|
+
|
|
|
732
|
+ DepCpp {dep_path} ->
|
|
|
733
|
+ mempty {cpp = Set.singleton dep_path}
|
|
|
734
|
+
|
|
503
|
735
|
|
|
504
|
736
|
-----------------------------------------------------------------
|
|
505
|
737
|
-- Module cycles
|