aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/HaskellCodeExplorer/PackageInfo.hs123
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.