-
-
Notifications
You must be signed in to change notification settings - Fork 389
/
Copy pathCompile.hs
1486 lines (1317 loc) · 69.5 KB
/
Compile.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
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
module Development.IDE.Core.Compile
( TcModuleResult(..)
, RunSimplifier(..)
, compileModule
, parseModule
, typecheckModule
, computePackageDeps
, addRelativeImport
, mkHiFileResultCompile
, mkHiFileResultNoCompile
, generateObjectCode
, generateByteCode
, generateHieAsts
, writeAndIndexHieFile
, indexHieFile
, writeHiFile
, getModSummaryFromImports
, loadHieFile
, loadInterface
, RecompilationInfo(..)
, loadModulesHome
, getDocsBatch
, lookupName
, mergeEnvs
, ml_core_file
, coreFileToLinkable
, TypecheckHelpers(..)
, sourceTypecheck
, sourceParser
, shareUsages
) where
import Control.Concurrent.STM.Stats hiding (orElse)
import Control.DeepSeq (NFData (..), force,
rnf)
import Control.Exception (evaluate)
import Control.Exception.Safe
import Control.Lens hiding (List, pre,
(<.>))
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Control.Monad.Trans.State.Strict as S
import Data.Aeson (toJSON)
import Data.Bifunctor (first, second)
import Data.Binary
import qualified Data.ByteString as BS
import Data.Coerce
import qualified Data.DList as DL
import Data.Functor
import Data.Generics.Aliases
import Data.Generics.Schemes
import qualified Data.HashMap.Strict as HashMap
import Data.IntMap (IntMap)
import Data.IORef
import Data.List.Extra
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Proxy (Proxy (Proxy))
import qualified Data.Text as T
import Data.Time (UTCTime (..))
import Data.Tuple.Extra (dupe)
import Debug.Trace
import Development.IDE.Core.FileStore (resetInterfaceStore)
import Development.IDE.Core.Preprocessor
import Development.IDE.Core.ProgressReporting (ProgressReporting (..))
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake
import Development.IDE.Core.Tracing (withTrace)
import Development.IDE.Core.WorkerThread (writeWorkerQueue)
import Development.IDE.GHC.Compat hiding (assert,
loadInterface,
parseHeader,
parseModule,
tcRnModule,
writeHieFile)
import qualified Development.IDE.GHC.Compat as Compat
import qualified Development.IDE.GHC.Compat as GHC
import qualified Development.IDE.GHC.Compat.Util as Util
import Development.IDE.Core.ProgressReporting (ProgressReporting (..), progressReportingOutsideState)
import Development.IDE.GHC.CoreFile
import Development.IDE.GHC.Error
import Development.IDE.GHC.Orphans ()
import Development.IDE.GHC.Util
import Development.IDE.GHC.Warnings
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import GHC (ForeignHValue,
GetDocsFailure (..),
parsedSource)
import qualified GHC.LanguageExtensions as LangExt
import GHC.Serialized
import HieDb hiding (withHieDb)
import qualified Language.LSP.Protocol.Message as LSP
import Language.LSP.Protocol.Types (DiagnosticTag (..))
import qualified Language.LSP.Server as LSP
import Prelude hiding (mod)
import System.Directory
import System.FilePath
import System.IO.Extra (fixIO,
newTempFileWithin)
import qualified Data.Set as Set
import qualified GHC as G
import GHC.Tc.Gen.Splice
import GHC.Types.ForeignStubs
import GHC.Types.HpcInfo
import GHC.Types.TypeEnv
-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
#if MIN_VERSION_ghc(9,5,0)
import GHC.Core.Lint.Interactive
import GHC.Driver.Config.CoreToStg.Prep
#endif
#if MIN_VERSION_ghc(9,7,0)
import Data.Foldable (toList)
import GHC.Unit.Module.Warnings
#else
import Development.IDE.Core.FileStore (shareFilePath)
#endif
--Simple constants to make sure the source is consistently named
sourceTypecheck :: T.Text
sourceTypecheck = "typecheck"
sourceParser :: T.Text
sourceParser = "parser"
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
parseModule
:: IdeOptions
-> HscEnv
-> FilePath
-> ModSummary
-> IO (IdeResult ParsedModule)
parseModule IdeOptions{..} env filename ms =
fmap (either (, Nothing) id) $
runExceptT $ do
(diag, modu) <- parseFileContents env optPreprocessor filename ms
return (diag, Just modu)
-- | Given a package identifier, what packages does it depend on
computePackageDeps
:: HscEnv
-> Unit
-> IO (Either [FileDiagnostic] [UnitId])
computePackageDeps env pkg = do
case lookupUnit env pkg of
Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
T.pack $ "unknown package: " ++ show pkg]
Just pkgInfo -> return $ Right $ unitDepends pkgInfo
newtype TypecheckHelpers
= TypecheckHelpers
{ getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files
}
typecheckModule :: IdeDefer
-> HscEnv
-> TypecheckHelpers
-> ParsedModule
-> IO (IdeResult TcModuleResult)
typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
let modSummary = pm_mod_summary pm
dflags = ms_hspp_opts modSummary
initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"
(initPlugins hsc modSummary)
case initialized of
Left errs -> return (errs, Nothing)
Right (modSummary', hscEnv) -> do
(warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->
let
session = tweak (hscSetFlags dflags hscEnv)
-- TODO: maybe settings ms_hspp_opts is unnecessary?
mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}
in
catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
let errorPipeline = unDefer . hideDiag dflags . tagDiag
diags = map errorPipeline warnings
deferredError = any fst diags
case etcm of
Left errs -> return (map snd diags ++ errs, Nothing)
Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
where
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
-- | Install hooks to capture the splices as well as the runtime module dependencies
captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)
captureSplicesAndDeps TypecheckHelpers{..} env k = do
splice_ref <- newIORef mempty
dep_ref <- newIORef emptyModuleEnv
res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)
splices <- readIORef splice_ref
needed_mods <- readIORef dep_ref
return (res, splices, needed_mods)
where
addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks
addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }
-- We want to record exactly which linkables/modules the typechecker needed at runtime
-- This is useful for recompilation checking.
-- See Note [Recompilation avoidance in the presence of TH]
--
-- From hscCompileCoreExpr' in GHC
-- To update, copy hscCompileCoreExpr' (the implementation of
-- hscCompileCoreExprHook) verbatim, and add code to extract all the free
-- names in the compiled bytecode, recording the modules that those names
-- come from in the IORef,, as these are the modules on whose implementation
-- we depend.
compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
compile_bco_hook var hsc_env srcspan ds_expr
= do { let dflags = hsc_dflags hsc_env
{- Simplify it -}
; simpl_expr <- simplifyExpr dflags hsc_env ds_expr
{- Tidy it (temporary, until coreSat does cloning) -}
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
{- Prepare for codegen -}
; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
{- Lint if necessary -}
; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing,
ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file",
ml_dyn_hi_file = panic "hscCompileCoreExpr':ml_dyn_hi_file",
ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file"
}
; let ictxt = hsc_IC hsc_env
; (binding_id, stg_expr, _, _) <-
myCoreToStgExpr (hsc_logger hsc_env)
(hsc_dflags hsc_env)
ictxt
True -- for bytecode
(icInteractiveModule ictxt)
iNTERACTIVELoc
prepd_expr
{- Convert to BCOs -}
; bcos <- byteCodeGen hsc_env
(icInteractiveModule ictxt)
stg_expr
[] Nothing
-- Exclude wired-in names because we may not have read
-- their interface files, so getLinkDeps will fail
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
-- Find the linkables for the modules we need
; let needed_mods = mkUniqSet [
mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids
| n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
, not (isWiredInName n) -- Exclude wired-in names
, Just mod <- [nameModule_maybe n] -- Names from other modules
, moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set
]
home_unit_ids =
map fst (hugElts $ hsc_HUG hsc_env)
mods_transitive = getTransitiveMods hsc_env needed_mods
-- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same
mods_transitive_list =
mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive
; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env)
; lbs <- getLinkables [toNormalizedFilePath' file
| installedMod <- mods_transitive_list
, let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs installedMod
file = case ifr of
InstalledFound loc _ ->
fromJust $ ml_hs_file loc
_ -> panic "hscCompileCoreExprHook: module not found"
]
; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env
{- load it -}
; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos
; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs, lbss, pkgs)
; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])
; return hval }
-- TODO: support backpack
nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule
-- We shouldn't get boot files here, but to be safe, never map them to an installed module
-- because boot files don't have linkables we can load, and we will fail if we try to look
-- for them
nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing
nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName
nodeKeyToInstalledModule _ = Nothing
moduleToNodeKey :: Module -> NodeKey
moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)
-- Compute the transitive set of linkables required
getTransitiveMods hsc_env needed_mods
= Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods
, Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))]
])
where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after
-- | Add a Hook to the DynFlags which captures and returns the
-- typechecked splices before they are run. This information
-- is used for hover.
addSpliceHook :: IORef Splices -> Hooks -> Hooks
addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) }
splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM
splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of
(MetaE f) -> do
expr' <- metaRequestE hook e
liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :)
pure $ f expr'
(MetaP f) -> do
pat' <- metaRequestP hook e
liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :)
pure $ f pat'
(MetaT f) -> do
type' <- metaRequestT hook e
liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :)
pure $ f type'
(MetaD f) -> do
decl' <- metaRequestD hook e
liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :)
pure $ f decl'
(MetaAW f) -> do
aw' <- metaRequestAW hook e
liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :)
pure $ f aw'
tcRnModule
:: HscEnv
-> TypecheckHelpers -- ^ Program linkables not to unload
-> ParsedModule
-> IO TcModuleResult
tcRnModule hsc_env tc_helpers pmod = do
let ms = pm_mod_summary pmod
hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
((tc_gbl_env', mrn_info), splices, mod_env)
<- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->
do hscTypecheckRename hscEnvTmp ms $
HsParsedModule { hpm_module = parsedSource pmod
, hpm_src_files = pm_extra_src_files pmod
}
let rn_info = case mrn_info of
Just x -> x
Nothing -> error "no renamed info tcRnModule"
-- Serialize mod_env so we can read it from the interface
mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
(moduleEnvToList mod_env)
tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
-- Note [Clearing mi_globals after generating an iface]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode
-- interpreter.
-- However, this field is expensive in terms of heap usage, and we don't use it in HLS
-- anywhere. So we zero it out.
-- The field is not serialized or deserialised from disk, so we don't need to remove it
-- while reading an iface from disk, only if we just generated an iface in memory
--
-- | See https://github.com/haskell/haskell-language-server/issues/3450
-- GHC's recompilation avoidance in the presense of TH is less precise than
-- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information
-- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH]
filterUsages :: [Usage] -> [Usage]
filterUsages = filter $ \case UsageHomeModuleInterface{} -> False
_ -> True
-- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744
-- Important to do this immediately after reading the unit before
-- anything else has a chance to read `mi_usages`
shareUsages :: ModIface -> ModIface
shareUsages iface
= iface
-- Fixed upstream in GHC 9.8
#if !MIN_VERSION_ghc(9,7,0)
{mi_usages = usages}
where usages = map go (mi_usages iface)
go usg@UsageFile{} = usg {usg_file_path = fp}
where !fp = shareFilePath (usg_file_path usg)
go usg = usg
#endif
mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
mkHiFileResultNoCompile session tcm = do
let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session
ms = pm_mod_summary $ tmrParsed tcm
tcGblEnv = tmrTypechecked tcm
details <- makeSimpleDetails hsc_env_tmp tcGblEnv
sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv
iface' <- mkIfaceTc hsc_env_tmp sf details ms Nothing tcGblEnv
let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface]
pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing
mkHiFileResultCompile
:: ShakeExtras
-> HscEnv
-> TcModuleResult
-> ModGuts
-> IO (IdeResult HiFileResult)
mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
let session = hscSetFlags (ms_hspp_opts ms) session'
ms = pm_mod_summary $ tmrParsed tcm
(details, guts) <- do
-- write core file
-- give variables unique OccNames
tidy_opts <- initTidyOpts session
(guts, details) <- tidyProgram tidy_opts simplified_guts
pure (details, guts)
let !partial_iface = force $ mkPartialIface session
#if MIN_VERSION_ghc(9,5,0)
(cg_binds guts)
#endif
details
ms
simplified_guts
final_iface' <- mkFullIface session partial_iface Nothing
#if MIN_VERSION_ghc(9,4,2)
Nothing
#endif
let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface]
-- Write the core file now
core_file <- do
let core_fp = ml_core_file $ ms_location ms
core_file = codeGutsToCoreFile iface_hash guts
iface_hash = getModuleHash final_iface
core_hash1 <- atomicFileWrite se core_fp $ \fp ->
writeBinCoreFile fp core_file
-- We want to drop references to guts and read in a serialized, compact version
-- of the core file from disk (as it is deserialised lazily)
-- This is because we don't want to keep the guts in memory for every file in
-- the project as it becomes prohibitively expensive
-- The serialized file however is much more compact and only requires a few
-- hundred megabytes of memory total even in a large project with 1000s of
-- modules
(coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp
pure $ assert (core_hash1 == core_hash2)
$ Just (coreFile, fingerprintToBS core_hash2)
-- Verify core file by roundtrip testing and comparison
IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se
case core_file of
Just (core, _) | optVerifyCoreFile -> do
let core_fp = ml_core_file $ ms_location ms
traceIO $ "Verifying " ++ core_fp
let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts
mod = ms_mod ms
data_tycons = filter isDataTyCon tycons
CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
#if MIN_VERSION_ghc(9,5,0)
cp_cfg <- initCorePrepConfig session
#endif
let corePrep = corePrepPgm
#if MIN_VERSION_ghc(9,5,0)
(hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session))
#else
session
#endif
mod (ms_location ms)
-- Run corePrep first as we want to test the final version of the program that will
-- get translated to STG/Bytecode
prepd_binds
<- corePrep unprep_binds data_tycons
prepd_binds'
<- corePrep unprep_binds' data_tycons
let binds = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds
binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds'
-- diffBinds is unreliable, sometimes it goes down the wrong track.
-- This fixes the order of the bindings so that it is less likely to do so.
diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'
-- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
-- diffs3 = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')
diffs = diffs2
go x y = S.state $ \s -> diffBinds True s x y
-- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
-- are used for generate core or bytecode, so we can safely ignore them
-- SYB is slow but fine given that this is only used for testing
noUnfoldings = everywhere $ mkT $ \v -> if isId v
then
let v' = if isOtherUnfolding (realIdUnfolding v) then setIdUnfolding v noUnfolding else v
in setIdOccInfo v' noOccInfo
else v
isOtherUnfolding (OtherCon _) = True
isOtherUnfolding _ = False
when (not $ null diffs) $
panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds']))
_ -> pure ()
pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)
where
dflags = hsc_dflags session'
source = "compile"
catchErrs x = x `catches`
[ Handler $ return . (,Nothing) . diagFromGhcException source dflags
, Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
. (("Error during " ++ T.unpack source) ++) . show @SomeException
]
-- | Whether we should run the -O0 simplifier when generating core.
--
-- This is required for template Haskell to work but we disable this in DAML.
-- See #256
newtype RunSimplifier = RunSimplifier Bool
-- | Compile a single type-checked module to a 'CoreModule' value, or
-- provide errors.
compileModule
:: RunSimplifier
-> HscEnv
-> ModSummary
-> TcGblEnv
-> IO (IdeResult ModGuts)
compileModule (RunSimplifier simplify) session ms tcg =
fmap (either (, Nothing) (second Just)) $
catchSrcErrors (hsc_dflags session) "compile" $ do
(warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do
-- Breakpoints don't survive roundtripping from disk
-- and this trips up the verify-core-files check
-- They may also lead to other problems.
-- We have to setBackend ghciBackend in 9.8 as otherwise
-- non-exported definitions are stripped out.
-- However, setting this means breakpoints are generated.
-- Solution: prevent breakpoing generation by unsetting
-- Opt_InsertBreakpoints
let session' = tweak $ flip hscSetFlags session
#if MIN_VERSION_ghc(9,7,0)
$ flip gopt_unset Opt_InsertBreakpoints
$ setBackend ghciBackend
#endif
$ ms_hspp_opts ms
-- TODO: maybe settings ms_hspp_opts is unnecessary?
-- MP: the flags in ModSummary should be right, if they are wrong then
-- the correct place to fix this is when the ModSummary is created.
desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg
if simplify
then do
plugins <- readIORef (tcg_th_coreplugins tcg)
hscSimplify session' plugins desugar
else pure desugar
return (map snd warnings, desugared_guts)
generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode session summary guts = do
fmap (either (, Nothing) (second Just)) $
catchSrcErrors (hsc_dflags session) "object" $ do
let dot_o = ml_obj_file (ms_location summary)
mod = ms_mod summary
fp = replaceExtension dot_o "s"
createDirectoryIfMissing True (takeDirectory fp)
(warnings, dot_o_fp) <-
withWarnings "object" $ \tweak -> do
let env' = tweak (hscSetFlags (ms_hspp_opts summary) session)
target = platformDefaultBackend (hsc_dflags env')
newFlags = setBackend target $ updOptLevel 0 $ setOutputFile
(Just dot_o)
$ hsc_dflags env'
session' = hscSetFlags newFlags session
#if MIN_VERSION_ghc(9,4,2)
(outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts
#else
(outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts
#endif
(ms_location summary)
fp
obj <- compileFile session' driverNoStop (outputFilename, Just (As False))
case obj of
Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"
Just x -> pure x
let unlinked = DotO dot_o_fp
-- Need time to be the modification time for recompilation checking
t <- liftIO $ getModificationTime dot_o_fp
let linkable = LM t mod [unlinked]
pure (map snd warnings, linkable)
newtype CoreFileTime = CoreFileTime UTCTime
generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode (CoreFileTime time) hscEnv summary guts = do
fmap (either (, Nothing) (second Just)) $
catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do
(warnings, (_, bytecode, sptEntries)) <-
withWarnings "bytecode" $ \_tweak -> do
let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)
-- TODO: maybe settings ms_hspp_opts is unnecessary?
summary' = summary { ms_hspp_opts = hsc_dflags session }
hscInteractive session (mkCgInteractiveGuts guts)
(ms_location summary')
let unlinked = BCOs bytecode sptEntries
let linkable = LM time (ms_mod summary) [unlinked]
pure (map snd warnings, linkable)
demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings =
(update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where
demoteTEsToWarns :: DynFlags -> DynFlags
-- convert the errors into warnings, and also check the warnings are enabled
demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)
. (`wopt_set` Opt_WarnTypedHoles)
. (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)
. (`gopt_set` Opt_DeferTypeErrors)
. (`gopt_set` Opt_DeferTypedHoles)
. (`gopt_set` Opt_DeferOutOfScopeVariables)
update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
update_pm_mod_summary up pm =
pm{pm_mod_summary = up $ pm_mod_summary pm}
unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)
unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors) , fd) = (True, upgradeWarningToError fd)
unDefer (Just (WarningWithFlag Opt_WarnTypedHoles) , fd) = (True, upgradeWarningToError fd)
unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd)
unDefer ( _ , fd) = (False, fd)
upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
upgradeWarningToError (nfp, sh, fd) =
(nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where
warn2err :: T.Text -> T.Text
warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))
| not (wopt warning originalFlags)
= (w, (nfp, HideDiag, fd))
hideDiag _originalFlags t = t
-- | Warnings which lead to a diagnostic tag
unnecessaryDeprecationWarningFlags :: [WarningFlag]
unnecessaryDeprecationWarningFlags
= [ Opt_WarnUnusedTopBinds
, Opt_WarnUnusedLocalBinds
, Opt_WarnUnusedPatternBinds
, Opt_WarnUnusedImports
, Opt_WarnUnusedMatches
, Opt_WarnUnusedTypePatterns
, Opt_WarnUnusedForalls
, Opt_WarnUnusedRecordWildcards
, Opt_WarnInaccessibleCode
#if !MIN_VERSION_ghc(9,7,0)
, Opt_WarnWarningsDeprecations
#endif
]
-- | Add a unnecessary/deprecated tag to the required diagnostics.
tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
#if MIN_VERSION_ghc(9,7,0)
tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd))
| cat == defaultWarningCategory -- default warning category is for deprecations
= (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) }))
tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd))
| tags <- mapMaybe requiresTag (toList warnings)
= (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))
#else
tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))
| Just tag <- requiresTag warning
= (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
#endif
where
requiresTag :: WarningFlag -> Maybe DiagnosticTag
#if !MIN_VERSION_ghc(9,7,0)
-- doesn't exist on 9.8, we use WarningWithCategory instead
requiresTag Opt_WarnWarningsDeprecations
= Just DiagnosticTag_Deprecated
#endif
requiresTag wflag -- deprecation was already considered above
| wflag `elem` unnecessaryDeprecationWarningFlags
= Just DiagnosticTag_Unnecessary
requiresTag _ = Nothing
-- other diagnostics are left unaffected
tagDiag t = t
addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport fp modu dflags = dflags
{importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
-- | Also resets the interface store
atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
atomicFileWrite se targetPath write = do
let dir = takeDirectory targetPath
createDirectoryIfMissing True dir
(tempFilePath, cleanUp) <- newTempFileWithin dir
(write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)
`onException` cleanUp
generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts hscEnv tcm =
handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do
-- These varBinds use unitDataConId but it could be anything as the id name is not used
-- during the hie file generation process. It's a workaround for the fact that the hie modules
-- don't export an interface which allows for additional information to be added to hie files.
let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm))
real_binds = tcg_binds $ tmrTypechecked tcm
ts = tmrTypechecked tcm :: TcGblEnv
top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind
insts = tcg_insts ts :: [ClsInst]
tcs = tcg_tcs ts :: [TyCon]
pure $ Just $
GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs
where
dflags = hsc_dflags hscEnv
spliceExpressions :: Splices -> [LHsExpr GhcTc]
spliceExpressions Splices{..} =
DL.toList $ mconcat
[ DL.fromList $ map fst exprSplices
, DL.fromList $ map fst patSplices
, DL.fromList $ map fst typeSplices
, DL.fromList $ map fst declSplices
, DL.fromList $ map fst awSplices
]
-- | In addition to indexing the `.hie` file, this function is responsible for
-- maintaining the 'IndexQueue' state and notifying the user about indexing
-- progress.
--
-- We maintain a record of all pending index operations in the 'indexPending'
-- TVar.
-- When 'indexHieFile' is called, it must check to ensure that the file hasn't
-- already be queued up for indexing. If it has, then we can just skip it
--
-- Otherwise, we record the current file as pending and write an indexing
-- operation to the queue
--
-- When the indexing operation is picked up and executed by the worker thread,
-- the first thing it does is ensure that a newer index for the same file hasn't
-- been scheduled by looking at 'indexPending'. If a newer index has been
-- scheduled, we can safely skip this one
--
-- Otherwise, we start or continue a progress reporting session, telling it
-- about progress so far and the current file we are attempting to index. Then
-- we can go ahead and call in to hiedb to actually do the indexing operation
--
-- Once this completes, we have to update the 'IndexQueue' state. First, we
-- must remove the just indexed file from 'indexPending' Then we check if
-- 'indexPending' is now empty. In that case, we end the progress session and
-- report the total number of file indexed. We also set the 'indexCompleted'
-- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we
-- can just increment the 'indexCompleted' TVar and exit.
--
indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO ()
indexHieFile se mod_summary srcPath !hash hf = do
atomically $ do
pending <- readTVar indexPending
case HashMap.lookup srcPath pending of
Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled
_ -> do
-- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
let !hf' = hf{hie_hs_src = mempty}
modifyTVar' indexPending $ HashMap.insert srcPath hash
writeWorkerQueue indexQueue $ \withHieDb -> do
-- We are now in the worker thread
-- Check if a newer index of this file has been scheduled, and if so skip this one
newerScheduled <- atomically $ do
pendingOps <- readTVar indexPending
pure $ case HashMap.lookup srcPath pendingOps of
Nothing -> False
-- If the hash in the pending list doesn't match the current hash, then skip
Just pendingHash -> pendingHash /= hash
unless newerScheduled $ do
-- Using bracket, so even if an exception happen during withHieDb call,
-- the `post` (which clean the progress indicator) will still be called.
bracket_ pre post $
withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')
where
mod_location = ms_location mod_summary
targetPath = Compat.ml_hie_file mod_location
HieDbWriter{..} = hiedbWriter se
pre = progressUpdate indexProgressReporting ProgressStarted
-- Report the progress once we are done indexing this file
post = do
mdone <- atomically $ do
-- Remove current element from pending
pending <- stateTVar indexPending $
dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath
modifyTVar' indexCompleted (+1)
-- If we are done, report and reset completed
whenMaybe (HashMap.null pending) $
swapTVar indexCompleted 0
whenJust (lspEnv se) $ \env -> LSP.runLspT env $
when (coerce $ ideTesting se) $
LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
toJSON $ fromNormalizedFilePath srcPath
whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted
writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =
handleGenerationErrors dflags "extended interface write/compression" $ do
hf <- runHsc hscEnv $
GHC.mkHieFile' mod_summary exports ast source
atomicFileWrite se targetPath $ flip GHC.writeHieFile hf
hash <- Util.getFileHash targetPath
indexHieFile se mod_summary srcPath hash hf
where
dflags = hsc_dflags hscEnv
mod_location = ms_location mod_summary
targetPath = Compat.ml_hie_file mod_location
writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile se hscEnv tc =
handleGenerationErrors dflags "interface write" $ do
atomicFileWrite se targetPath $ \fp ->
writeIfaceFile hscEnv fp modIface
where
modIface = hirModIface tc
targetPath = ml_hi_file $ ms_location $ hirModSummary tc
dflags = hsc_dflags hscEnv
handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
handleGenerationErrors dflags source action =
action >> return [] `catches`
[ Handler $ return . diagFromGhcException source dflags
, Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
. (("Error during " ++ T.unpack source) ++) . show @SomeException
]
handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
handleGenerationErrors' dflags source action =
fmap ([],) action `catches`
[ Handler $ return . (,Nothing) . diagFromGhcException source dflags
, Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
. (("Error during " ++ T.unpack source) ++) . show @SomeException
]
-- Merge the HPTs, module graphs and FinderCaches
-- See Note [GhcSessionDeps] in Development.IDE.Core.Rules
-- Add the current ModSummary to the graph, along with the
-- HomeModInfo's of all direct dependencies (by induction hypothesis all
-- transitive dependencies will be contained in envs)
mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
mergeEnvs env mg ms extraMods envs = do
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
ifr = InstalledFound (ms_location ms) im
curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
return $! loadModulesHome extraMods $
let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
(hscUpdateHUG (const newHug) env){
hsc_FC = newFinderCache,
hsc_mod_graph = mg
}
where
mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }
mergeUDFM = plusUDFM_C combineModules
combineModules a b
| HsSrcFile <- mi_hsc_src (hm_iface a) = a
| otherwise = b
-- Prefer non-boot files over non-boot files
-- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816
-- if a boot file shadows over a non-boot file
combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a
combineModuleLocations _ b = b
concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache
concatFC cur xs = do
fcModules <- mapM (readIORef . fcModuleCache) xs
fcFiles <- mapM (readIORef . fcFileCache) xs
fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules
fcFiles' <- newIORef $! Map.unions fcFiles
pure $ FinderCache fcModules' fcFiles'
withBootSuffix :: HscSource -> ModLocation -> ModLocation
withBootSuffix HsBootFile = addBootSuffixLocnOut
withBootSuffix _ = id
-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
-- Runs preprocessors as needed.
getModSummaryFromImports
:: HscEnv
-> FilePath
-> UTCTime
-> Maybe Util.StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
-- modTime is only used in GHC < 9.4
getModSummaryFromImports env fp _modTime mContents = do
-- src_hash is only used in GHC >= 9.4
(contents, opts, ppEnv, _src_hash) <- preprocessor env fp mContents
let dflags = hsc_dflags ppEnv
-- The warns will hopefully be reported when we actually parse the module
(_warns, L main_loc hsmod) <- parseHeader dflags fp contents
-- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports
let mb_mod = hsmodName hsmod
imps = hsmodImports hsmod
mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME
(src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps
-- GHC.Prim doesn't exist physically, so don't go looking for it.
-- ghc_prim_imports is only used in GHC >= 9.4
(ordinary_imps, _ghc_prim_imports)
= partition ((/= moduleName gHC_PRIM) . unLoc
. ideclName . unLoc)
ord_idecls
implicit_prelude = xopt LangExt.ImplicitPrelude dflags
implicit_imports = mkPrelImports mod main_loc
implicit_prelude imps
convImport (L _ i) = (
(ideclPkgQual i)
, reLoc $ ideclName i)
msrImports = implicit_imports ++ imps
rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv)
rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
srcImports = rn_imps $ map convImport src_idecls
textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)
ghc_prim_import = not (null _ghc_prim_imports)
-- Force bits that might keep the string buffer and DynFlags alive unnecessarily
liftIO $ evaluate $ rnf srcImports
liftIO $ evaluate $ rnf textualImports
modLoc <- liftIO $ if mod == mAIN_NAME
-- specially in tests it's common to have lots of nameless modules
-- mkHomeModLocation will map them to the same hi/hie locations
then mkHomeModLocation dflags (pathToModuleName fp) fp
else mkHomeModLocation dflags mod fp
let modl = mkHomeModule (hscHomeUnit ppEnv) mod
sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
msrModSummary2 =
ModSummary
{ ms_mod = modl
, ms_hie_date = Nothing
, ms_dyn_obj_date = Nothing
, ms_ghc_prim_import = ghc_prim_import
, ms_hs_hash = _src_hash
, ms_hsc_src = sourceType
-- The contents are used by the GetModSummary rule
, ms_hspp_buf = Just contents
, ms_hspp_file = fp
, ms_hspp_opts = dflags
, ms_iface_date = Nothing
, ms_location = withBootSuffix sourceType modLoc