diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index 7b4617d5..f1a51e72 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -303,11 +303,7 @@ writeHiFile hscEnv tc = writeIfaceFile dflags fp modIface where modIface = hm_iface $ tmrModInfo tc - modSummary = tmrModSummary tc - targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc - withBootSuffix = case ms_hsc_src modSummary of - HsBootFile -> addBootSuffix - _ -> id + targetPath = ml_hi_file $ ms_location $ tmrModSummary tc dflags = hsc_dflags hscEnv handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] @@ -409,6 +405,10 @@ getImportsParsed dflags (L loc parsed) = do , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim" ]) +withBootSuffix :: HscSource -> ModLocation -> ModLocation +withBootSuffix HsBootFile = addBootSuffixLocnOut +withBootSuffix _ = id + -- | Produce a module summary from a StringBuffer. getModSummaryFromBuffer :: GhcMonad m @@ -425,7 +425,7 @@ getModSummaryFromBuffer fp modTime dflags parsed contents = do let InstalledUnitId unitId = thisInstalledUnitId dflags return $ ModSummary { ms_mod = mkModule (fsToUnitId unitId) modName - , ms_location = modLoc + , ms_location = withBootSuffix sourceType modLoc , ms_hs_date = modTime , ms_textual_imps = [imp | (False, imp) <- imports] , ms_hspp_file = fp @@ -485,7 +485,7 @@ getModSummaryFromImports fp modTime contents = do , ms_hspp_file = fp , ms_hspp_opts = dflags , ms_iface_date = Nothing - , ms_location = modLoc + , ms_location = withBootSuffix sourceType modLoc , ms_obj_date = Nothing , ms_parsed_mod = Nothing , ms_srcimps = srcImports diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 5f7324ec..a0928b11 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -685,9 +685,7 @@ isHiFileStableRule :: Rules () isHiFileStableRule = define $ \IsHiFileStable f -> do ms <- use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' - $ case ms_hsc_src ms of - HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms) - _ -> ml_hi_file $ ms_location ms + $ ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile modVersion <- use_ GetModificationTime f sourceModified <- case mbHiVersion of diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs index 05566840..a849f864 100644 --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -23,6 +23,7 @@ module Development.IDE.GHC.Compat( dontWriteHieFiles, #if !MIN_GHC_API_VERSION(8,8,0) ml_hie_file, + addBootSuffixLocnOut, #endif hPutStringBuffer, includePathsGlobal, @@ -122,6 +123,7 @@ import System.FilePath ((-<.>)) #if MIN_GHC_API_VERSION(8,6,0) import GhcPlugins (srcErrorMessages) +import Data.List (isSuffixOf) #else import System.IO.Error import IfaceEnv @@ -153,7 +155,9 @@ hieExportNames = nameListFromAvails . hie_exports #if !MIN_GHC_API_VERSION(8,8,0) ml_hie_file :: GHC.ModLocation -> FilePath -ml_hie_file ml = ml_hi_file ml -<.> ".hie" +ml_hie_file ml + | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" + | otherwise = ml_hi_file ml -<.> ".hie" #endif #endif @@ -380,6 +384,14 @@ instance HasSrcSpan (GenLocated SrcSpan a) where getHeaderImports a b c d = catch (Right <$> Hdr.getImports a b c d) (return . Left . srcErrorMessages) + +-- | Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation +addBootSuffixLocnOut locn + = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn) + , ml_obj_file = Module.addBootSuffix (ml_obj_file locn) + } #endif getModuleHash :: ModIface -> Fingerprint diff --git a/test/data/boot/A.hs b/test/data/boot/A.hs new file mode 100644 index 00000000..7f0bcca7 --- /dev/null +++ b/test/data/boot/A.hs @@ -0,0 +1,8 @@ +module A where + +import B( TB(..) ) + +newtype TA = MkTA Int + +f :: TB -> TA +f (MkTB x) = MkTA x diff --git a/test/data/boot/A.hs-boot b/test/data/boot/A.hs-boot new file mode 100644 index 00000000..04f7eece --- /dev/null +++ b/test/data/boot/A.hs-boot @@ -0,0 +1,2 @@ +module A where +newtype TA = MkTA Int diff --git a/test/data/boot/B.hs b/test/data/boot/B.hs new file mode 100644 index 00000000..8bf96dcb --- /dev/null +++ b/test/data/boot/B.hs @@ -0,0 +1,7 @@ +module B(TA(..), TB(..)) where +import {-# SOURCE #-} A( TA(..) ) + +data TB = MkTB !Int + +g :: TA -> TB +g (MkTA x) = MkTB x diff --git a/test/data/boot/C.hs b/test/data/boot/C.hs new file mode 100644 index 00000000..f90e9604 --- /dev/null +++ b/test/data/boot/C.hs @@ -0,0 +1,8 @@ +module C where + +import B +import A hiding (MkTA(..)) + +x = MkTA +y = MkTB +z = f diff --git a/test/data/boot/hie.yaml b/test/data/boot/hie.yaml new file mode 100644 index 00000000..1909df7d --- /dev/null +++ b/test/data/boot/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["A", "B", "C"]}} diff --git a/test/exe/Main.hs b/test/exe/Main.hs index e7d447a9..3c4891d5 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -87,6 +87,7 @@ main = do , nonLspCommandLine , benchmarkTests , ifaceTests + , bootTests ] initializeResponseTests :: TestTree @@ -2796,6 +2797,22 @@ ifaceTests = testGroup "Interface loading tests" , ifaceTHTest ] +bootTests :: TestTree +bootTests = testCase "boot-def-test" $ withoutStackEnv $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + _ <- getHover cDoc $ Position 4 3 + closeDoc cDoc + + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 7 0 7 1 + checkDefs locs (pure [floc]) + -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree ifaceTHTest = testCase "iface-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do