diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HaskellCodeExplorer/PackageInfo.hs | 123 |
1 files changed, 66 insertions, 57 deletions
diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs index b31be70..279a9a1 100644 --- a/src/HaskellCodeExplorer/PackageInfo.hs +++ b/src/HaskellCodeExplorer/PackageInfo.hs @@ -10,6 +10,7 @@ module HaskellCodeExplorer.PackageInfo ( createPackageInfo + , testCreatePkgInfo , ghcVersion ) where import qualified Data.List.NonEmpty as NE @@ -32,6 +33,7 @@ import Control.Monad.Logger , logDebugN , logErrorN , logInfoN + , runStdoutLoggingT ) import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM @@ -128,6 +130,10 @@ import System.FilePath import System.FilePath.Find (find,always,(==?),fileName) import System.Process (readProcess) +testCreatePkgInfo :: FilePath -> IO (HCE.PackageInfo HCE.ModuleInfo) +testCreatePkgInfo pkgPath = runStdoutLoggingT $ + createPackageInfo pkgPath Nothing HCE.AfterPreprocessing [] [] + createPackageInfo :: FilePath -- ^ Path to a Cabal package -> Maybe FilePath -- ^ Relative path to a dist directory @@ -142,12 +148,13 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces 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 + Nothing -> return $ packageDirectoryAbsPath </> "dist-newstyle" + -- Nothing -> do + -- eitherDistDir <- findDistDirectory packageDirectoryAbsPath + -- case eitherDistDir of + -- Right distDir -> return distDir + -- Left errorMessage -> + -- logErrorN (T.pack errorMessage) >> liftIO exitFailure cabalFiles <- liftIO $ length . @@ -186,6 +193,8 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces -- (zip3 <$> components ((,) <$> ghcOptions) <*> -- components ((,) <$> entrypoints) <*> -- components ((,) <$> sourceDirs))) + -- logInfoN $ "unitinfo: " <> (T.pack $ show (packageName, packageVersion)) + -- logInfoN $ "compinfo: " <> (T.pack $ show compInfo) let currentPackageId = HCE.PackageId (T.pack packageName) packageVersion unless (take 3 (versionBranch packageCompilerVersion) == @@ -393,57 +402,57 @@ addReferencesFromModule references modInfo@HCE.ModuleInfo {..} = 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" +-- 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. |