Skip to content

Commit

Permalink
Fix .hie file location for .hs-boot files (haskell/ghcide#690)
Browse files Browse the repository at this point in the history
* Find source for boot files

* fix modlocs for boot files

* Add test

* Fix build on 8.6
  • Loading branch information
wz1000 authored Sep 2, 2020
1 parent a7215c6 commit 17455d1
Show file tree
Hide file tree
Showing 9 changed files with 64 additions and 11 deletions.
14 changes: 7 additions & 7 deletions ghcide/src/Development/IDE/Core/Compile.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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]
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 1 addition & 3 deletions ghcide/src/Development/IDE/Core/Rules.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
14 changes: 13 additions & 1 deletion ghcide/src/Development/IDE/GHC/Compat.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
8 changes: 8 additions & 0 deletions ghcide/test/data/boot/A.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@
module A where

import B( TB(..) )

newtype TA = MkTA Int

f :: TB -> TA
f (MkTB x) = MkTA x
2 changes: 2 additions & 0 deletions ghcide/test/data/boot/A.hs-boot
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
module A where
newtype TA = MkTA Int
7 changes: 7 additions & 0 deletions ghcide/test/data/boot/B.hs
Original file line number Diff line number Diff line change
@@ -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
8 changes: 8 additions & 0 deletions ghcide/test/data/boot/C.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@
module C where

import B
import A hiding (MkTA(..))

x = MkTA
y = MkTB
z = f
1 change: 1 addition & 0 deletions ghcide/test/data/boot/hie.yaml
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
cradle: {direct: {arguments: ["A", "B", "C"]}}
17 changes: 17 additions & 0 deletions ghcide/test/exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -87,6 +87,7 @@ main = do
, nonLspCommandLine
, benchmarkTests
, ifaceTests
, bootTests
]

initializeResponseTests :: TestTree
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 17455d1

Please sign in to comment.