{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module HaskellCodeExplorer.PackageInfo ( createPackageInfo , ghcVersion ) where import Control.DeepSeq(deepseq) import Control.Exception ( IOException , SomeAsyncException , SomeException , fromException , throw , try ) import Control.Monad (foldM, unless) import Control.Monad.Extra (anyM, findM) import Control.Monad.Logger ( LoggingT(..) , MonadLogger(..) , MonadLoggerIO(..) , logDebugN , logErrorN , logInfoN ) import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import Data.IORef (readIORef) import qualified Data.IntMap.Strict as IM import qualified Data.List as L import Data.Maybe (fromMaybe, isJust, maybeToList) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Version (Version(..), showVersion, makeVersion) import Digraph (flattenSCCs) import Distribution.Helper ( ChComponentName(..) , ChEntrypoint(..) , ChModuleName(..) , components , entrypoints , ghcOptions , mkQueryEnv , packageId , runQuery , sourceDirs , compilerVersion ) import DynFlags ( DynFlags(..) , GeneralFlag(..) , GhcMode(..) , WarnReason(..) , gopt_set , parseDynamicFlagsCmdLine ) import Exception (ExceptionMonad(..), ghandle) import GHC ( GhcLink(..) , HscTarget(..) , LoadHowMuch(..) , ModLocation(..) , ModSummary(..) , Severity , SrcSpan , getModuleGraph , getSession , getSessionDynFlags , guessTarget , load , noLoc , parseModule , runGhcT , setSessionDynFlags , setTargets , topSortModuleGraph , typecheckModule , moduleNameString , moduleName ) import GHC.Paths (libdir) import GhcMonad (GhcT(..), liftIO) import HaskellCodeExplorer.GhcUtils (isHsBoot,toText) import HaskellCodeExplorer.ModuleInfo (ModuleDependencies, createModuleInfo) import qualified HaskellCodeExplorer.Types as HCE import HscTypes (hsc_EPS, hsc_HPT) import Outputable (PprStyle, SDoc, neverQualify, showSDocForUser) import Packages (initPackages) import Prelude hiding (id) import System.Directory ( doesFileExist , findExecutable , setCurrentDirectory , getCurrentDirectory , makeAbsolute ) import qualified System.Directory.Tree as DT import System.Exit (exitFailure) import System.FilePath ( () , addTrailingPathSeparator , joinPath , normalise , replaceExtension , splitPath , takeExtension , takeBaseName , takeDirectory , splitDirectories ) import System.FilePath.Find (find,always,(==?),fileName) import System.Process (readProcess) createPackageInfo :: FilePath -- ^ Path to a Cabal package -> Maybe FilePath -- ^ Relative path to a dist directory -> HCE.SourceCodePreprocessing -- ^ Before or after preprocessor -> [String] -- ^ Options for GHC -> [String] -- ^ Directories to ignore -> LoggingT IO (HCE.PackageInfo HCE.ModuleInfo) createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreprocessing additionalGhcOptions ignoreDirectories = do packageDirectoryAbsPath <- liftIO $ makeAbsolute packageDirectoryPath currentDirectory <- liftIO getCurrentDirectory liftIO $ setCurrentDirectory packageDirectoryAbsPath distDir <- case mbDistDirRelativePath of Just path -> return $ packageDirectoryAbsPath path Nothing -> do eitherDistDir <- findDistDirectory packageDirectoryAbsPath case eitherDistDir of Right distDir -> return distDir Left errorMessage -> logErrorN (T.pack errorMessage) >> liftIO exitFailure let cabalHelperQueryEnv = mkQueryEnv packageDirectoryAbsPath distDir ((packageName, packageVersion), (_packageCompilerName, packageCompilerVersion), compInfo) <- liftIO $ runQuery cabalHelperQueryEnv ((,,) <$> packageId <*> compilerVersion <*> (zip3 <$> components ((,) <$> ghcOptions) <*> components ((,) <$> entrypoints) <*> components ((,) <$> sourceDirs))) let currentPackageId = HCE.PackageId (T.pack packageName) packageVersion unless (take 3 (versionBranch packageCompilerVersion) == take 3 (versionBranch ghcVersion)) $ do logErrorN $ T.concat [ "GHC version mismatch. haskell-code-indexer: " , T.pack $ showVersion ghcVersion , ", package: " , T.pack $ showVersion packageCompilerVersion ] liftIO exitFailure logInfoN $ T.append "Indexing " $ HCE.packageIdToText currentPackageId let buildComponents = L.map (\((options, compName), (entrypoint, _), (srcDirs, _)) -> ( chComponentNameToComponentId compName , options , chEntrypointsToModules entrypoint , srcDirs , chComponentNameToComponentType compName)) . L.sortBy (\((_, compName1), _, _) ((_, compName2), _, _) -> compare compName1 compName2) $ compInfo libSrcDirs = concatMap (\(_, _, _, srcDirs, _) -> srcDirs) . filter (\(_, _, _, _, compType) -> HCE.isLibrary compType) $ buildComponents (indexedModules, (_fileMapResult, _defSiteMapResult, modNameMapResult)) <- foldM (\(modules, (fileMap, defSiteMap, modNameMap)) (compId, options, (mbMain, moduleNames), srcDirs, _) -> do mbMainPath <- case mbMain of Just mainPath -> liftIO $ findM doesFileExist $ mainPath : map (\srcDir -> normalise $ srcDir mainPath) srcDirs Nothing -> return Nothing (modules', (fileMap', defSiteMap', modNameMap')) <- indexBuildComponent sourceCodePreprocessing currentPackageId compId (fileMap, defSiteMap, modNameMap) srcDirs libSrcDirs (options ++ additionalGhcOptions) (maybe moduleNames (: moduleNames) mbMainPath) return (modules ++ modules', (fileMap', defSiteMap', modNameMap'))) ([], (HM.empty, HM.empty, HM.empty)) buildComponents let modId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath moduleMap = HM.fromList . map (\modInfo -> (modId modInfo, modInfo)) $ indexedModules references = L.foldl' addReferencesFromModule HM.empty indexedModules moduleId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath topLevelIdentifiersTrie = L.foldl' addTopLevelIdentifiersFromModule HCE.emptyTrie . L.filter (not . isHsBoot . moduleId) $ indexedModules directoryTree <- liftIO $ buildDirectoryTree packageDirectoryAbsPath ignoreDirectories (\path -> HM.member (HCE.HaskellModulePath . T.pack $ path) moduleMap) liftIO $ setCurrentDirectory currentDirectory return HCE.PackageInfo { id = currentPackageId , moduleMap = moduleMap , moduleNameMap = modNameMapResult , directoryTree = directoryTree , externalIdOccMap = references , externalIdInfoMap = topLevelIdentifiersTrie } where chEntrypointsToModules :: ChEntrypoint -> (Maybe String, [String]) chEntrypointsToModules (ChLibEntrypoint modules otherModules signatures) = ( Nothing , L.map chModuleToString modules ++ L.map chModuleToString otherModules ++ L.map chModuleToString signatures) chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) = (Just mainModule, []) chEntrypointsToModules ChSetupEntrypoint = (Nothing, []) chModuleToString :: ChModuleName -> String chModuleToString (ChModuleName n) = n chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType chComponentNameToComponentType ChSetupHsName = HCE.Setup chComponentNameToComponentType ChLibName = HCE.Lib chComponentNameToComponentType (ChSubLibName name) = HCE.SubLib $ T.pack name chComponentNameToComponentType (ChFLibName name) = HCE.FLib $ T.pack name chComponentNameToComponentType (ChExeName name) = HCE.Exe $ T.pack name chComponentNameToComponentType (ChTestName name) = HCE.Test $ T.pack name chComponentNameToComponentType (ChBenchName name) = HCE.Bench $ T.pack name chComponentNameToComponentId :: ChComponentName -> HCE.ComponentId chComponentNameToComponentId ChLibName = HCE.ComponentId "lib" chComponentNameToComponentId (ChSubLibName name) = HCE.ComponentId . T.append "sublib-" . T.pack $ name chComponentNameToComponentId (ChFLibName name) = HCE.ComponentId . T.append "flib-" . T.pack $ name chComponentNameToComponentId (ChExeName name) = HCE.ComponentId . T.append "exe-" . T.pack $ name chComponentNameToComponentId (ChTestName name) = HCE.ComponentId . T.append "test-" . T.pack $ name chComponentNameToComponentId (ChBenchName name) = HCE.ComponentId . T.append "bench-" . T.pack $ name chComponentNameToComponentId ChSetupHsName = HCE.ComponentId "setup" #if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) ghcVersion :: Version ghcVersion = makeVersion [8, 6, 5, 0] #elif MIN_VERSION_GLASGOW_HASKELL(8,6,4,0) ghcVersion :: Version ghcVersion = makeVersion [8, 6, 4, 0] #elif MIN_VERSION_GLASGOW_HASKELL(8,6,3,0) ghcVersion :: Version ghcVersion = makeVersion [8, 6, 3, 0] #elif MIN_VERSION_GLASGOW_HASKELL(8,4,4,0) ghcVersion :: Version ghcVersion = makeVersion [8, 4, 4, 0] #elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) ghcVersion :: Version ghcVersion = makeVersion [8, 4, 3, 0] #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) ghcVersion :: Version ghcVersion = makeVersion [8, 2, 2, 0] #else ghcVersion :: Version ghcVersion = makeVersion [8, 0, 2, 0] #endif buildDirectoryTree :: FilePath -> [FilePath] -> (FilePath -> Bool) -> IO HCE.DirTree buildDirectoryTree path ignoreDirectories isHaskellModule = do (_dir DT.:/ tree) <- DT.readDirectoryWith (const . return $ ()) path -- Tuple up the complete file path with the file contents, by building up the path, -- trie-style, from the root. The filepath will be relative to "anchored" directory. let treeWithPaths = DT.zipPaths ("" DT.:/ DT.filterDir (not . ignore) tree) return $ toDirTree (removeTopDir . fst <$> treeWithPaths) where ignore :: DT.DirTree a -> Bool ignore (DT.Dir dirName _) | "." `L.isPrefixOf` dirName = True | dirName == "dist" = True | dirName == "dist-newstyle" = True | dirName == "tmp" = True | otherwise = dirName `elem` ignoreDirectories ignore (DT.Failed _ _) = True ignore _ = False removeTopDir :: FilePath -> FilePath removeTopDir p = case splitPath p of _x:xs -> joinPath xs [] -> "" toDirTree :: DT.DirTree FilePath -> HCE.DirTree toDirTree (DT.Dir name contents) = HCE.Dir name (map toDirTree . filter (not . DT.failed) $ contents) toDirTree (DT.File name filePath) = HCE.File name filePath (isHaskellModule filePath) toDirTree (DT.Failed name err) = HCE.File (name ++ " : " ++ show err) "" False addTopLevelIdentifiersFromModule :: HCE.Trie Char HCE.ExternalIdentifierInfo -> HCE.ModuleInfo -> HCE.Trie Char HCE.ExternalIdentifierInfo addTopLevelIdentifiersFromModule trieIdInfo HCE.ModuleInfo {..} = L.foldl' (\trie idInfo@(HCE.ExternalIdentifierInfo HCE.IdentifierInfo {..}) -> HCE.insertToTrie S.insert (T.unpack demangledOccName) idInfo trie) trieIdInfo externalIds addReferencesFromModule :: HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan) -> HCE.ModuleInfo -> HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan) addReferencesFromModule references modInfo@HCE.ModuleInfo {..} = eachIdentifierOccurrence references modInfo (\occMap lineNumber startCol endCol occ -> let mbIdExternalId = HCE.externalId =<< maybe Nothing (`HM.lookup` idInfoMap) (HCE.internalId (occ :: HCE.IdentifierOccurrence)) idSrcSpan = HCE.IdentifierSrcSpan { modulePath = id , line = lineNumber , startColumn = startCol , endColumn = endCol } in case mbIdExternalId of Just externalId -> HM.insertWith S.union externalId (S.singleton idSrcSpan) occMap Nothing -> occMap) findDistDirectory :: FilePath -> LoggingT IO (Either String FilePath) findDistDirectory packagePath = do let parents = reverse . map joinPath . filter (not . null) . L.inits . splitPath $ packagePath -- e.g., ["/dir/subdir/subsubdir","/dir/subdir/","/dir/","/"] hasStackYaml <- liftIO $ anyM (\path -> doesFileExist (path "stack.yaml")) parents mbStackExecutable <- liftIO $ findExecutable "stack" case (hasStackYaml, mbStackExecutable) of (True, Just stack) -> do let removeEndOfLine str | null str = str | otherwise = init str logInfoN "Found stack.yaml. Executing \"stack path --dist-dir\" to get dist directory." eitherDistDir :: (Either IOException String) <- liftIO . try . fmap removeEndOfLine . readProcess stack ["path", "--dist-dir"] $ "" case eitherDistDir of Right distDir -> do logInfoN $ T.append "Stack dist directory : " $ T.pack distDir hasSetupConfig <- liftIO $ doesFileExist $ distDir "setup-config" if hasSetupConfig then return $ Right distDir else return $ Left "Cannot find setup-config file in a dist directory. Has the package been built?" Left exception -> return $ Left $ "Error while executing \"stack path --dist-dir\" : " ++ show exception _ -> do logInfoN "Trying to find dist directory" setupConfigPaths <- liftIO $ map (takeDirectory . normalise) <$> find always (fileName ==? "setup-config") "." case setupConfigPaths of [] -> return $ Left "Cannot find dist directory. Has the package been built?" [path] -> do logInfoN $ T.append "Found dist directory : " $ T.pack path return $ Right path _ -> return $ Left $ "Found multiple possible dist directories : \n" ++ show setupConfigPaths ++ " \nPlease specify --dist option" eachIdentifierOccurrence :: forall a. a -> HCE.ModuleInfo -> (a -> IM.Key -> Int -> Int -> HCE.IdentifierOccurrence -> a) -> a eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f = IM.foldlWithKey' (\acc lineNumber occurences -> L.foldl' (\a ((startCol, endCol), occ) -> f a lineNumber startCol endCol occ) acc occurences) accumulator idOccMap instance ExceptionMonad (LoggingT IO) where gcatch act h = LoggingT $ \logFn -> runLoggingT act logFn `gcatch` \e -> runLoggingT (h e) logFn gmask f = LoggingT $ \logFn -> gmask $ \io_restore -> let g_restore (LoggingT m) = LoggingT $ \lf -> io_restore (m lf) in runLoggingT (f g_restore) logFn instance MonadLoggerIO (GhcT (LoggingT IO)) where askLoggerIO = GhcT $ const askLoggerIO instance MonadLogger (GhcT (LoggingT IO)) where monadLoggerLog loc source level = GhcT . const . monadLoggerLog loc source level gtrySync :: (ExceptionMonad m) => m a -> m (Either SomeException a) gtrySync action = ghandleSync (return . Left) (fmap Right action) ghandleSync :: (ExceptionMonad m) => (SomeException -> m a) -> m a -> m a ghandleSync onError = ghandle (\ex -> case fromException ex of Just (asyncEx :: SomeAsyncException) -> throw asyncEx _ -> onError ex) indexBuildComponent :: HCE.SourceCodePreprocessing -- ^ Before or after preprocessor -> HCE.PackageId -- ^ Current package id -> HCE.ComponentId -- ^ Current component id -> ModuleDependencies -- ^ Already indexed modules -> [FilePath] -- ^ Src dirs -> [FilePath] -- ^ Src dirs of libraries -> [String] -- ^ Command-line options for GHC -> [String] -- ^ Modules to compile -> LoggingT IO ([HCE.ModuleInfo],ModuleDependencies) indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(fileMap, defSiteMap, modNameMap) srcDirs libSrcDirs options modules = do let onError ex = do logErrorN $ T.concat [ "Error while indexing component " , HCE.getComponentId componentId , " : " , T.pack . show $ ex ] return ([], deps) ghandleSync onError $ runGhcT (Just libdir) $ do logDebugN (T.append "Component id : " $ HCE.getComponentId componentId) logDebugN (T.append "Modules : " $ T.pack $ show modules) logDebugN (T.append "GHC command line options : " $ T.pack $ L.unwords (options ++ modules)) flags <- getSessionDynFlags (flags', _, _) <- parseDynamicFlagsCmdLine flags (L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal (flags'', _) <- liftIO $ initPackages flags' logFn <- askLoggerIO let logAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> Outputable.PprStyle -> SDoc -> IO () logAction fs _reason _severity srcSpan _stype msg = runLoggingT (logDebugN (T.append "GHC message : " $ T.pack $ showSDocForUser fs neverQualify msg ++ " , SrcSpan : " ++ show srcSpan)) logFn mbTmpDir = case hiDir flags'' of Just buildDir -> Just $ buildDir (takeBaseName buildDir ++ "-tmp") Nothing -> Nothing _ <- setSessionDynFlags $ L.foldl' gopt_set (flags'' { hscTarget = HscAsm , ghcLink = LinkInMemory , ghcMode = CompManager , log_action = logAction , importPaths = importPaths flags'' ++ maybeToList mbTmpDir }) [Opt_Haddock] targets <- mapM (`guessTarget` Nothing) modules setTargets targets _ <- load LoadAllTargets modGraph <- getModuleGraph let topSortMods = flattenSCCs (topSortModuleGraph False modGraph Nothing) buildDir = addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $ flags'' pathsModuleName = "Paths_" ++ map (\c -> if c == '-' then '_' else c) (T.unpack (HCE.name (currentPackageId :: HCE.PackageId))) (modSumWithPath, modulesNotFound) <- (\(mods, notFound) -> ( L.reverse . L.foldl' (\acc (mbPath, modSum) -> case mbPath of Just path | not $ HM.member path defSiteMap -> (path, modSum) : acc _ -> acc) [] $ mods , map snd notFound)) . L.partition (\(mbPath, _) -> isJust mbPath) <$> mapM (\modSum -> liftIO $ (, modSum) <$> findHaskellModulePath buildDir (srcDirs ++ libSrcDirs) modSum) (filter (\modSum -> pathsModuleName /= (moduleNameString . moduleName $ ms_mod modSum)) topSortMods) unless (null modulesNotFound) $ logErrorN $ T.append "Cannot find module path : " (toText flags'' $ map ms_mod modulesNotFound) foldM (\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) -> do result <- indexModule sourceCodePreprocessing componentId currentPackageId flags'' (fileMap', defSiteMap', modNameMap') (modulePath, modSum) case result of Right (modInfo, (fileMap'', defSiteMap'', modNameMap'')) -> return ( modInfo : indexedModules , (fileMap'', defSiteMap'', modNameMap'')) Left exception -> do logErrorN $ T.concat [ "Error while indexing " , T.pack . show $ modulePath , " : " , T.pack . show $ exception ] return (indexedModules, (fileMap', defSiteMap', modNameMap'))) ([], (fileMap, defSiteMap, modNameMap)) modSumWithPath findHaskellModulePath :: FilePath -> [FilePath] -> ModSummary -> IO (Maybe HCE.HaskellModulePath) findHaskellModulePath buildDir srcDirs modSum = case normalise <$> (ml_hs_file . ms_location $ modSum) of Just modulePath -> let toHaskellModulePath = return . Just . HCE.HaskellModulePath . T.pack removeTmpDir path = case splitDirectories path of parent:rest -> if "-tmp" `L.isSuffixOf` parent then joinPath rest else path _ -> path in case removeTmpDir <$> L.stripPrefix buildDir modulePath of -- File is in the build directory Just path | takeExtension path == ".hs-boot" -> do let possiblePaths = path : map ( path) srcDirs mbFoundPath <- findM doesFileExist possiblePaths case mbFoundPath of Just p -> toHaskellModulePath p _ -> return Nothing | takeExtension path == ".hs" -> do let paths = map (replaceExtension path) HCE.haskellPreprocessorExtensions possiblePaths = paths ++ concatMap (\srcDir -> map (srcDir ) paths) srcDirs mbFoundPath <- findM doesFileExist possiblePaths case mbFoundPath of Just p -> toHaskellModulePath p _ -> return Nothing | otherwise -> return Nothing Nothing -> toHaskellModulePath modulePath Nothing -> return Nothing indexModule :: HCE.SourceCodePreprocessing -> HCE.ComponentId -> HCE.PackageId -> DynFlags -> ModuleDependencies -> (HCE.HaskellModulePath, ModSummary) -> GhcT (LoggingT IO) (Either SomeException ( HCE.ModuleInfo , ModuleDependencies)) indexModule sourceCodePreprocessing componentId currentPackageId flags deps (modulePath, modSum) = gtrySync $ do logDebugN (T.append "Indexing " $ HCE.getHaskellModulePath modulePath) parsedModule <- parseModule modSum typecheckedModule <- typecheckModule parsedModule hscEnv <- getSession externalPackageState <- liftIO . readIORef . hsc_EPS $ hscEnv originalSourceCode <- liftIO $ T.replace "\t" " " . TE.decodeUtf8 <$> BS.readFile (T.unpack . HCE.getHaskellModulePath $ modulePath) let (modInfo, (fileMap', exportMap', moduleNameMap'), typeErrors) = createModuleInfo deps ( flags , typecheckedModule , hsc_HPT hscEnv , externalPackageState , modSum) modulePath currentPackageId componentId (originalSourceCode, sourceCodePreprocessing) unless (null typeErrors) $ logInfoN $ T.append "Type errors : " $ T.pack $ show typeErrors deepseq modInfo $ return (modInfo, (fileMap', exportMap', moduleNameMap'))