diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -6,8 +6,8 @@ import qualified Config as GHC import Control.Monad import Control.Monad.IO.Class -import Data.Char (isUpper) import Data.List (find, isPrefixOf) +import Data.Maybe (catMaybes) import DynFlags (parseDynamicFlagsCmdLine, updOptLevel) import qualified EnumSet as EnumSet import qualified GHC as GHC @@ -16,6 +16,8 @@ import HsInspect.Json import HsInspect.Packages import HsInspect.Sexp as S +import HsInspect.Util +import HsInspect.Workarounds import System.Environment (getArgs) import System.Exit @@ -53,7 +55,7 @@ flags' = filter (not . ("-B" `isPrefixOf`)) flags GHC.runGhc libdir $ do dflags <- GHC.getSessionDynFlags - (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> ghcargs, _) <- + (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> _ghcargs, _) <- liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags') void $ GHC.setSessionDynFlags dflags' { GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why @@ -62,8 +64,14 @@ , GHC.warningFlags = EnumSet.empty , GHC.fatalWarningFlags = EnumSet.empty } - let mkTarget m = GHC.Target (GHC.TargetModule $ GHC.mkModuleName m) True Nothing - GHC.setTargets $ mkTarget <$> filter (isUpper . head) ghcargs + + -- The caller may have provided a list of home modules, but we do not trust + -- them because the ghcflags plugin does not keep the flags up to date for + -- incremental compiles. + let mkTarget m = GHC.Target (GHC.TargetModule m) True Nothing + homeModules <- inferHomeModules + GHC.setTargets $ mkTarget <$> homeModules + let respond rest (S.filterNil . S.toSexp -> a) = liftIO . putStrLn $ if (elem "--json" rest) then case sexpToJson a of @@ -82,6 +90,13 @@ respond rest hits _ -> liftIO $ error "invalid parameters" + +inferHomeModules :: GHC.GhcMonad m => m [GHC.ModuleName] +inferHomeModules = do + files <- homeSources + mmns <- traverse parseModuleName' files + let main' = GHC.mkModuleName "Main" + pure . filter (main' /=) $ catMaybes mmns -- removes the "+RTS ... -RTS" sections filterFlags :: [String] -> [String] diff --git a/hsinspect.cabal b/hsinspect.cabal --- a/hsinspect.cabal +++ b/hsinspect.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hsinspect -version: 0.0.10 +version: 0.0.11 synopsis: Inspect Haskell source files. license: GPL-3.0-or-later license-file: LICENSE diff --git a/library/HsInspect/Imports.hs b/library/HsInspect/Imports.hs --- a/library/HsInspect/Imports.hs +++ b/library/HsInspect/Imports.hs @@ -9,12 +9,11 @@ where import Data.Maybe (fromJust) -import DynFlags (unsafeGlobalDynFlags) import qualified GHC as GHC import HscTypes (TargetId(..)) import HsInspect.Sexp import HsInspect.Workarounds -import Outputable (Outputable, showPpr) +import HsInspect.Util import RdrName (GlobalRdrElt(..), ImpDeclSpec(..), ImportSpec(..), globalRdrEnvElts) @@ -33,9 +32,6 @@ rdr_env <- minf_rdr_env' m pure $ describe =<< globalRdrEnvElts rdr_env - -showGhc :: (Outputable a) => a -> String -showGhc = showPpr unsafeGlobalDynFlags describe :: GlobalRdrElt -> [Qualified] describe GRE {gre_name, gre_imp} = describe' <$> gre_imp diff --git a/library/HsInspect/Index.hs b/library/HsInspect/Index.hs --- a/library/HsInspect/Index.hs +++ b/library/HsInspect/Index.hs @@ -30,7 +30,6 @@ import HsInspect.Sexp import HsInspect.Util import qualified Id as GHC -import Module (Module(..), moduleNameString) import Module as GHC import qualified Name as GHC import Outputable (showPpr, showSDoc) @@ -129,6 +128,8 @@ -> m (Maybe (GHC.Module, [(Maybe GHC.Module, GHC.TcTyThing)])) hiToSymbols exposed hi = (join <$>) <$> withHi hi $ \iface -> do let m = mi_module iface + -- FIXME we should include all modules from inplace packages, otherwise the + -- user is unable to jump-to-definition within the same multi-package project. if not $ Set.member (GHC.moduleName m) exposed then pure Nothing else do @@ -185,6 +186,8 @@ -- srcid is Nothing if it matches the re-export location data Exported = Exported (Maybe SourcePackageId) GHC.ModuleName +-- FIXME Exported should follow re-exports until they reach the original symbol. +-- Otherwise editors have to do this. mkExported :: GHC.DynFlags -> UnitId -> Module -> Exported mkExported dflags unitid m = let unitid' = moduleUnitId m diff --git a/library/HsInspect/Packages.hs b/library/HsInspect/Packages.hs --- a/library/HsInspect/Packages.hs +++ b/library/HsInspect/Packages.hs @@ -8,8 +8,9 @@ import Control.Monad (join, void) import Control.Monad.IO.Class (liftIO) import Data.Coerce -import Data.List (delete, nub, sort, (\\)) +import Data.List (delete, nub, nubBy, sort, (\\)) import Data.Maybe (catMaybes, mapMaybe) +import Data.Set (Set) import qualified Data.Set as Set import qualified DynFlags as GHC import FastString @@ -28,19 +29,29 @@ -- separate -ddump-minimal-imports pass). packages :: GHC.GhcMonad m => m PkgSummary packages = do - mods <- Set.toList <$> getTargetModules + homes <- getTargetModules + targetsImportsOnly homes dflags <- GHC.getSessionDynFlags void $ GHC.setSessionDynFlags dflags { GHC.ghcMode = GHC.CompManager } _ <- GHC.load $ GHC.LoadAllTargets - imps <- nub . join <$> traverse getImports mods + imps <- nub . join <$> traverse getImports (Set.toList homes) pkgs <- catMaybes <$> traverse (uncurry findPackage) imps let home = GHC.thisPackage dflags used = delete home . nub . sort $ pkgs loaded = nub . sort . explicitPackages $ GHC.pkgState dflags asNames unitids = GHC.packageName <$> mapMaybe (lookupPackage dflags) unitids pure $ PkgSummary (asNames used) (asNames $ loaded \\ used) + +targetsImportsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> m () +targetsImportsOnly homes = do + files <- homeSources + trimmed <- traverse (importsOnly homes) files + -- side effect: multiple modules with no name will be deduped + let fstEq (n1, _) (n2, _) = n1 == n2 + targets = (snd <$>) . nubBy fstEq $ trimmed + GHC.setTargets targets findPackage :: GHC.GhcMonad m => ModuleName -> Maybe FastString -> m (Maybe GHC.UnitId) findPackage m mp = do diff --git a/library/HsInspect/Util.hs b/library/HsInspect/Util.hs --- a/library/HsInspect/Util.hs +++ b/library/HsInspect/Util.hs @@ -1,14 +1,26 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} module HsInspect.Util where -import Data.List (isSuffixOf) +import Control.Monad.IO.Class +import Data.List (isSuffixOf, nub) import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.Set as Set +import DynFlags (unsafeGlobalDynFlags) import qualified GHC as GHC -import System.Directory (doesDirectoryExist, listDirectory) +import Outputable (Outputable, showPpr) +import System.Directory (doesDirectoryExist, listDirectory, makeAbsolute) + +homeSources :: GHC.GhcMonad m => m [FilePath] +homeSources = do + dflags <- GHC.getSessionDynFlags + paths <- liftIO . traverse makeAbsolute $ GHC.importPaths dflags + let infer dir = liftIO $ walkSuffix ".hs" dir + nub . concat <$> traverse infer paths + +showGhc :: (Outputable a) => a -> String +showGhc = showPpr unsafeGlobalDynFlags getTargetModules :: GHC.GhcMonad m => m (Set GHC.ModuleName) getTargetModules = do diff --git a/library/HsInspect/Workarounds.hs b/library/HsInspect/Workarounds.hs --- a/library/HsInspect/Workarounds.hs +++ b/library/HsInspect/Workarounds.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module HsInspect.Workarounds where @@ -9,7 +10,6 @@ import Data.List (delete, intercalate, isSuffixOf) import Data.Set (Set) import qualified Data.Set as Set -import DriverPhases (HscSource(..), Phase(..)) import DriverPipeline (preprocess) import DynFlags (parseDynamicFilePragma) import FastString @@ -24,16 +24,17 @@ import SrcLoc import StringBuffer import System.Directory (getModificationTime, removeFile) + +#if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0) +import Data.Maybe (fromJust, fromMaybe) +import OccName (emptyOccEnv) +#else import TcRnTypes (tcg_rdr_env) +#endif --- TODO avoid this codepath in 8.8.2+ --- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541 -importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target) -importsOnly homes file = do +parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs) +parseHeader' file = do sess <- GHC.getSession - -- NOTE: the behaviour of preprocess changed in 8.8.1 and it no longer reads - -- and sets LANGUAGE pragamas from in header of the file. Since this function - -- is no longer needed in 8.8.2 we don't bother fixing this. #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) pp <- liftIO $ preprocess sess file Nothing Nothing let (dflags, tmp) = case pp of @@ -47,38 +48,57 @@ liftIO . removeFile $ tmp let pragmas = getOptions dflags full file loc = mkRealSrcLoc (mkFastString file) 1 1 - allowed (L _ (ImportDecl{ideclName})) = Set.notMember (unLoc ideclName) homes + (dflags', _, _) <- parseDynamicFilePragma dflags pragmas + case unP parseHeader (mkPState dflags' full loc) of + POk _ (L _ hsmod) -> pure (unLoc <$> pragmas, hsmod) + _ -> error $ "parseHeader failed for " <> file + +importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target) +importsOnly homes file = do + dflags <- GHC.getSessionDynFlags + (pragmas, hsmod) <- parseHeader' file + let allowed (L _ (ImportDecl{ideclName})) = Set.notMember (unLoc ideclName) homes #if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) allowed (L _ (XImportDecl _)) = False #endif - (dflags', _, _) <- parseDynamicFilePragma dflags pragmas - (modname, trimmed) <- case unP parseHeader (mkPState dflags' full loc) of - POk _ (L _ hsmod) -> do - let modname = unLoc <$> GHC.hsmodName hsmod - extra = - if modname == Nothing || modname == (Just $ GHC.mkModuleName "Main") - then "\nmain = return ()" - else "" - imps = filter allowed $ GHC.hsmodImports hsmod - -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066 - -- cannot use CPP in combination with targetContents - pragmas' = delete "-XCPP" (unLoc <$> pragmas) - contents = - "{-# OPTIONS_GHC " <> (intercalate " " pragmas') <> " #-}\n" <> - showPpr dflags' (hsmod { GHC.hsmodExports = Nothing - , GHC.hsmodImports = imps }) <> - extra - pure (modname, stringToStringBuffer contents) - _ -> error $ "parseHeader failed for " <> file + modname = unLoc <$> GHC.hsmodName hsmod + extra = + if modname == Nothing || modname == (Just $ GHC.mkModuleName "Main") + then "\nmain = return ()" + else "" + imps = filter allowed $ GHC.hsmodImports hsmod + -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066 + -- cannot use CPP in combination with targetContents + pragmas' = delete "-XCPP" pragmas + contents = + "{-# OPTIONS_GHC " <> (intercalate " " pragmas') <> " #-}\n" <> + showPpr dflags (hsmod { GHC.hsmodExports = Nothing + , GHC.hsmodImports = imps }) <> + extra + trimmed = stringToStringBuffer contents ts <- liftIO $ getModificationTime file - pure $ (modname, Target (TargetFile file (Just $ Hsc HsSrcFile)) False (Just (trimmed, ts))) + -- since 0f9ec9d1ff can't use Phase + pure $ (modname, Target (TargetFile file Nothing) False (Just (trimmed, ts))) +parseModuleName' :: GHC.GhcMonad m => FilePath -> m (Maybe GHC.ModuleName) +parseModuleName' file = do + (_, hsmod) <- parseHeader' file + pure $ unLoc <$> GHC.hsmodName hsmod + -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541 minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GlobalRdrEnv minf_rdr_env' m = do +#if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0) + mo <- GHC.findModule m Nothing + (fromJust -> mi) <- GHC.getModuleInfo mo + pure . fromMaybe emptyOccEnv $ GHC.modInfoRdrEnv mi +#else modSum <- GHC.getModSummary m pmod <- GHC.parseModule modSum tmod <- GHC.typecheckModule pmod let (tc_gbl_env, _) = GHC.tm_internals_ tmod pure $ tcg_rdr_env tc_gbl_env +#endif + +