mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 09:17:43 +03:00
ghcide: support hs-boot files (#2827)
This commit is contained in:
parent
e6646ec8e1
commit
bb90002e66
@ -22,7 +22,8 @@
|
|||||||
"languages": [{
|
"languages": [{
|
||||||
"id": "haskell",
|
"id": "haskell",
|
||||||
"extensions": [
|
"extensions": [
|
||||||
"hs"
|
"hs",
|
||||||
|
"hs-boot"
|
||||||
]
|
]
|
||||||
}],
|
}],
|
||||||
"configuration": {
|
"configuration": {
|
||||||
|
@ -45,6 +45,8 @@ import qualified GHC.LanguageExtensions as LangExt
|
|||||||
import Control.Monad.Extra
|
import Control.Monad.Extra
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
|
import Data.Function
|
||||||
|
import Data.Ord
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
@ -149,7 +151,12 @@ mkTcModuleResult tcm = do
|
|||||||
-- | Setup the environment that GHC needs according to our
|
-- | Setup the environment that GHC needs according to our
|
||||||
-- best understanding (!)
|
-- best understanding (!)
|
||||||
setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
|
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
|
session <- getSession
|
||||||
|
|
||||||
let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
|
let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
|
||||||
@ -191,24 +198,17 @@ loadModuleHome tmr = modifySession $ \e ->
|
|||||||
-- name and its imports.
|
-- name and its imports.
|
||||||
getImportsParsed :: DynFlags ->
|
getImportsParsed :: DynFlags ->
|
||||||
GHC.ParsedSource ->
|
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
|
getImportsParsed dflags (L loc parsed) = do
|
||||||
let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
|
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
|
-- 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
|
-- but we want to avoid parsing the module twice
|
||||||
let implicit_prelude = xopt GHC.ImplicitPrelude dflags
|
let implicit_prelude = xopt GHC.ImplicitPrelude dflags
|
||||||
implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
|
implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
|
||||||
|
|
||||||
-- filter out imports that come from packages
|
-- 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
|
| i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
|
||||||
, GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
|
, GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
|
||||||
])
|
])
|
||||||
@ -227,10 +227,10 @@ getModSummaryFromBuffer fp contents dflags parsed = do
|
|||||||
|
|
||||||
let modLoc = ModLocation
|
let modLoc = ModLocation
|
||||||
{ ml_hs_file = Just fp
|
{ ml_hs_file = Just fp
|
||||||
, ml_hi_file = replaceExtension fp "hi"
|
, ml_hi_file = derivedFile "hi"
|
||||||
, ml_obj_file = replaceExtension fp "o"
|
, ml_obj_file = derivedFile "o"
|
||||||
#ifndef GHC_STABLE
|
#ifndef GHC_STABLE
|
||||||
, ml_hie_file = replaceExtension fp "hie"
|
, ml_hie_file = derivedFile "hie"
|
||||||
#endif
|
#endif
|
||||||
-- This does not consider the dflags configuration
|
-- This does not consider the dflags configuration
|
||||||
-- (-osuf and -hisuf, object and hi dir.s).
|
-- (-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
|
-- 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
|
-- has not changed, we make sure that things blow up if they depend on the
|
||||||
-- date.
|
-- date.
|
||||||
, ms_textual_imps = imports
|
, ms_textual_imps = [imp | (False, imp) <- imports]
|
||||||
, ms_hspp_file = fp
|
, ms_hspp_file = fp
|
||||||
, ms_hspp_opts = dflags
|
, ms_hspp_opts = dflags
|
||||||
, ms_hspp_buf = Just contents
|
, ms_hspp_buf = Just contents
|
||||||
|
|
||||||
-- defaults:
|
-- defaults:
|
||||||
, ms_hsc_src = HsSrcFile
|
, ms_hsc_src = sourceType
|
||||||
, ms_obj_date = Nothing
|
, ms_obj_date = Nothing
|
||||||
, ms_iface_date = Nothing
|
, ms_iface_date = Nothing
|
||||||
#ifndef GHC_STABLE
|
#ifndef GHC_STABLE
|
||||||
, ms_hie_date = Nothing
|
, ms_hie_date = Nothing
|
||||||
#endif
|
#endif
|
||||||
, ms_srcimps = [] -- source imports are not allowed
|
, ms_srcimps = [imp | (True, imp) <- imports]
|
||||||
, ms_parsed_mod = Nothing
|
, 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
|
-- | Run CPP on a file
|
||||||
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||||
|
@ -183,12 +183,12 @@ getLocatedImportsRule =
|
|||||||
define $ \GetLocatedImports file -> do
|
define $ \GetLocatedImports file -> do
|
||||||
pm <- use_ GetParsedModule file
|
pm <- use_ GetParsedModule file
|
||||||
let ms = pm_mod_summary pm
|
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
|
env <- useNoFile_ GhcSession
|
||||||
let dflags = addRelativeImport pm $ hsc_dflags env
|
let dflags = addRelativeImport pm $ hsc_dflags env
|
||||||
opt <- getIdeOptions
|
opt <- getIdeOptions
|
||||||
(diags, imports') <- fmap unzip $ forM imports $ \(mbPkgName, modName) -> do
|
(diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
|
||||||
diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName
|
diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
|
||||||
case diagOrImp of
|
case diagOrImp of
|
||||||
Left diags -> pure (diags, Left (modName, Nothing))
|
Left diags -> pure (diags, Left (modName, Nothing))
|
||||||
Right (FileImport path) -> pure ([], Left (modName, Just path))
|
Right (FileImport path) -> pure ([], Left (modName, Just path))
|
||||||
|
@ -42,11 +42,18 @@ locateModuleFile :: MonadIO m
|
|||||||
=> DynFlags
|
=> DynFlags
|
||||||
-> [String]
|
-> [String]
|
||||||
-> (NormalizedFilePath -> m Bool)
|
-> (NormalizedFilePath -> m Bool)
|
||||||
|
-> Bool
|
||||||
-> ModuleName
|
-> ModuleName
|
||||||
-> m (Maybe NormalizedFilePath)
|
-> m (Maybe NormalizedFilePath)
|
||||||
locateModuleFile dflags exts doesExist modName = do
|
locateModuleFile dflags exts doesExist isSource modName = do
|
||||||
let candidates = [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> ext) | prefix <- importPaths dflags, ext <- exts]
|
let candidates =
|
||||||
|
[ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
|
||||||
|
| prefix <- importPaths dflags, ext <- exts]
|
||||||
findM doesExist candidates
|
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
|
-- | locate a module in either the file system or the package database. Where we go from *daml to
|
||||||
-- Haskell
|
-- Haskell
|
||||||
@ -57,15 +64,16 @@ locateModule
|
|||||||
-> (NormalizedFilePath -> m Bool)
|
-> (NormalizedFilePath -> m Bool)
|
||||||
-> Located ModuleName
|
-> Located ModuleName
|
||||||
-> Maybe FastString
|
-> Maybe FastString
|
||||||
|
-> Bool
|
||||||
-> m (Either [FileDiagnostic] Import)
|
-> m (Either [FileDiagnostic] Import)
|
||||||
locateModule dflags exts doesExist modName mbPkgName = do
|
locateModule dflags exts doesExist modName mbPkgName isSource = do
|
||||||
case mbPkgName of
|
case mbPkgName of
|
||||||
-- if a package name is given we only go look for a package
|
-- if a package name is given we only go look for a package
|
||||||
Just _pkgName -> lookupInPackageDB dflags
|
Just _pkgName -> lookupInPackageDB dflags
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
-- first try to find the module as a file. If we can't find it try to find it in the package
|
-- first try to find the module as a file. If we can't find it try to find it in the package
|
||||||
-- database.
|
-- database.
|
||||||
mbFile <- locateModuleFile dflags exts doesExist $ unLoc modName
|
mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
|
||||||
case mbFile of
|
case mbFile of
|
||||||
Nothing -> lookupInPackageDB dflags
|
Nothing -> lookupInPackageDB dflags
|
||||||
Just file -> return $ Right $ FileImport file
|
Just file -> return $ Right $ FileImport file
|
||||||
|
@ -125,6 +125,47 @@ diagnosticTests = testGroup "diagnostics"
|
|||||||
, [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
|
, [(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
|
, testSession "redundant import" $ do
|
||||||
let contentA = T.unlines ["module ModuleA where"]
|
let contentA = T.unlines ["module ModuleA where"]
|
||||||
let contentB = T.unlines
|
let contentB = T.unlines
|
||||||
|
Loading…
Reference in New Issue
Block a user