digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 09:17:43 +03:00
Code Issues Projects Releases Wiki Activity

ghcide: support hs-boot files (#2827)

Browse Source
This commit is contained in:
Ganesh Sittampalam 2019-09-10 10:35:52 +01:00 committed by Moritz Kiefer
parent e6646ec8e1
commit bb90002e66
5 changed files with 80 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
compiler/ghcide/extension/package.json
View File

@ -22,7 +22,8 @@
"languages": [{
"id": "haskell",
"extensions": [
"hs"
"hs",
"hs-boot"
]
}],
"configuration": {

38
compiler/ghcide/src/Development/IDE/Core/Compile.hs
View File

@ -45,6 +45,8 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad.Extra
import Control.Monad.Except
import Control.Monad.Trans.Except
import Data.Function
import Data.Ord
import qualified Data.Text as T
import Data.IORef
import Data.List.Extra
@ -149,7 +151,12 @@ mkTcModuleResult tcm = do
-- | Setup the environment that GHC needs according to our
-- best understanding (!)
setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
setupEnv tms = do
setupEnv tmsIn = do
-- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
-- takes precedence, so put the .hs-boot file earlier in the list
let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
tms = sortBy (compare `on` Down . isSourceFile) tmsIn
session <- getSession
let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
@ -191,24 +198,17 @@ loadModuleHome tmr = modifySession $ \e ->
-- name and its imports.
getImportsParsed :: DynFlags ->
GHC.ParsedSource ->
Either [FileDiagnostic] (GHC.ModuleName, [(Maybe FastString, Located GHC.ModuleName)])
Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
getImportsParsed dflags (L loc parsed) = do
let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
-- refuse source imports
let srcImports = filter (ideclSource . GHC.unLoc) $ GHC.hsmodImports parsed
when (not $ null srcImports) $ Left $
concat
[ diagFromString "imports" mloc ("Illegal source import of " <> GHC.moduleNameString (GHC.unLoc $ GHC.ideclName i))
| L mloc i <- srcImports ]
-- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
-- but we want to avoid parsing the module twice
let implicit_prelude = xopt GHC.ImplicitPrelude dflags
implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
-- filter out imports that come from packages
return (modName, [(fmap sl_fs $ ideclPkgQual i, ideclName i)
return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
| i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
, GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
])
@ -227,10 +227,10 @@ getModSummaryFromBuffer fp contents dflags parsed = do
let modLoc = ModLocation
{ ml_hs_file = Just fp
, ml_hi_file = replaceExtension fp "hi"
, ml_obj_file = replaceExtension fp "o"
, ml_hi_file = derivedFile "hi"
, ml_obj_file = derivedFile "o"
#ifndef GHC_STABLE
, ml_hie_file = replaceExtension fp "hie"
, ml_hie_file = derivedFile "hie"
#endif
-- This does not consider the dflags configuration
-- (-osuf and -hisuf, object and hi dir.s).
@ -245,21 +245,27 @@ getModSummaryFromBuffer fp contents dflags parsed = do
-- To avoid silent issues where something is not processed because the date
-- has not changed, we make sure that things blow up if they depend on the
-- date.
, ms_textual_imps = imports
, ms_textual_imps = [imp | (False, imp) <- imports]
, ms_hspp_file = fp
, ms_hspp_opts = dflags
, ms_hspp_buf = Just contents
-- defaults:
, ms_hsc_src = HsSrcFile
, ms_hsc_src = sourceType
, ms_obj_date = Nothing
, ms_iface_date = Nothing
#ifndef GHC_STABLE
, ms_hie_date = Nothing
#endif
, ms_srcimps = [] -- source imports are not allowed
, ms_srcimps = [imp | (True, imp) <- imports]
, ms_parsed_mod = Nothing
}
where
(sourceType, derivedFile) =
let (stem, ext) = splitExtension fp in
if "-boot" `isSuffixOf` ext
then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
else (HsSrcFile , \newExt -> stem <.> newExt)
-- | Run CPP on a file
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

6
compiler/ghcide/src/Development/IDE/Core/Rules.hs
View File

@ -183,12 +183,12 @@ getLocatedImportsRule =
define $ \GetLocatedImports file -> do
pm <- use_ GetParsedModule file
let ms = pm_mod_summary pm
let imports = ms_textual_imps ms
let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
env <- useNoFile_ GhcSession
let dflags = addRelativeImport pm $ hsc_dflags env
opt <- getIdeOptions
(diags, imports') <- fmap unzip $ forM imports $ \(mbPkgName, modName) -> do
diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName
(diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
case diagOrImp of
Left diags -> pure (diags, Left (modName, Nothing))
Right (FileImport path) -> pure ([], Left (modName, Just path))

16
compiler/ghcide/src/Development/IDE/Import/FindImports.hs
View File

@ -42,11 +42,18 @@ locateModuleFile :: MonadIO m
=> DynFlags
-> [String]
-> (NormalizedFilePath -> m Bool)
-> Bool
-> ModuleName
-> m (Maybe NormalizedFilePath)
locateModuleFile dflags exts doesExist modName = do
let candidates = [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> ext) | prefix <- importPaths dflags, ext <- exts]
locateModuleFile dflags exts doesExist isSource modName = do
let candidates =
[ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
| prefix <- importPaths dflags, ext <- exts]
findM doesExist candidates
where
maybeBoot ext
| isSource = ext ++ "-boot"
| otherwise = ext
-- | locate a module in either the file system or the package database. Where we go from *daml to
-- Haskell
@ -57,15 +64,16 @@ locateModule
-> (NormalizedFilePath -> m Bool)
-> Located ModuleName
-> Maybe FastString
-> Bool
-> m (Either [FileDiagnostic] Import)
locateModule dflags exts doesExist modName mbPkgName = do
locateModule dflags exts doesExist modName mbPkgName isSource = do
case mbPkgName of
-- if a package name is given we only go look for a package
Just _pkgName -> lookupInPackageDB dflags
Nothing -> do
-- first try to find the module as a file. If we can't find it try to find it in the package
-- database.
mbFile <- locateModuleFile dflags exts doesExist $ unLoc modName
mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
case mbFile of
Nothing -> lookupInPackageDB dflags
Just file -> return $ Right $ FileImport file

41
compiler/ghcide/test/exe/Main.hs
View File

@ -125,6 +125,47 @@ diagnosticTests = testGroup "diagnostics"
, [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
)
]
, testSession "cyclic module dependency with hs-boot" $ do
let contentA = T.unlines
[ "module ModuleA where"
, "import {-# SOURCE #-} ModuleB"
]
let contentB = T.unlines
[ "module ModuleB where"
, "import ModuleA"
]
let contentBboot = T.unlines
[ "module ModuleB where"
]
_ <- openDoc' "ModuleA.hs" "haskell" contentA
_ <- openDoc' "ModuleB.hs" "haskell" contentB
_ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
expectDiagnostics []
, testSession "correct reference used with hs-boot" $ do
let contentB = T.unlines
[ "module ModuleB where"
, "import {-# SOURCE #-} ModuleA"
]
let contentA = T.unlines
[ "module ModuleA where"
, "import ModuleB"
, "x = 5"
]
let contentAboot = T.unlines
[ "module ModuleA where"
]
let contentC = T.unlines
[ "module ModuleC where"
, "import ModuleA"
-- this reference will fail if it gets incorrectly
-- resolved to the hs-boot file
, "y = x"
]
_ <- openDoc' "ModuleB.hs" "haskell" contentB
_ <- openDoc' "ModuleA.hs" "haskell" contentA
_ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
_ <- openDoc' "ModuleC.hs" "haskell" contentC
expectDiagnostics []
, testSession "redundant import" $ do
let contentA = T.unlines ["module ModuleA where"]
let contentB = T.unlines