Merge pull request #3615 from commercialhaskell/parse-cabal-files-once

Don't parse cabal files twice

src/Stack/Build.hs

@@ -44,7 +44,7 @@ import           Stack.Build.Source
 import           Stack.Build.Target
 import           Stack.Fetch as Fetch
 import           Stack.Package
-import           Stack.PackageLocation (loadSingleRawCabalFile)
+import           Stack.PackageLocation (parseSingleCabalFileIndex)
 import           Stack.Types.Build
 import           Stack.Types.BuildPlan
 import           Stack.Types.Config
@@ -281,17 +281,10 @@ withLoadPackage inner = do
     root <- view projectRootL
     run <- askRunInIO
     withCabalLoader $ \loadFromIndex ->
-        inner $ \loc flags ghcOptions -> do
-            bs <- run $ loadSingleRawCabalFile loadFromIndex root loc
-
-            -- Intentionally ignore warnings, as it's not really
-            -- appropriate to print a bunch of warnings out while
-            -- resolving the package index.
-            (_warnings,pkg) <- readPackageBS
+        inner $ \loc flags ghcOptions -> run $
+            resolvePackage
               (depPackageConfig econfig flags ghcOptions)
-              loc
-              bs
-            return pkg
+              <$> parseSingleCabalFileIndex loadFromIndex root loc
   where
     -- | Package config to be used for dependencies
     depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig

src/Stack/Build/Source.hs

@@ -30,7 +30,7 @@ import qualified    Data.Map.Strict as M
 import qualified    Data.Set as Set
 import              Stack.Build.Cache
 import              Stack.Build.Target
-import              Stack.Config (getLocalPackages, getNamedComponents)
+import              Stack.Config (getLocalPackages)
 import              Stack.Constants (wiredInPackages)
 import              Stack.Package
 import              Stack.PackageLocation
@@ -94,24 +94,9 @@ loadSourceMapFull needTargets boptsCli = do
             -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon
             PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir
             PLOther pl -> do
-              -- FIXME lots of code duplication with getLocalPackages
               root <- view projectRootL
-              dir <- resolveSinglePackageLocation root pl
-              cabalfp <- findOrGenerateCabalFile dir
-              bs <- liftIO (S.readFile (toFilePath cabalfp))
-              (warnings, gpd) <-
-                case rawParseGPD bs of
-                  Left e -> throwM $ InvalidCabalFileInLocal (PLOther pl) e bs
-                  Right x -> return x
-              mapM_ (printCabalFileWarning cabalfp) warnings
-              lp' <- loadLocalPackage False boptsCli targets (n, LocalPackageView
-                { lpvVersion = lpiVersion lpi
-                , lpvRoot = dir
-                , lpvCabalFP = cabalfp
-                , lpvComponents = getNamedComponents gpd
-                , lpvGPD = gpd
-                , lpvLoc = pl
-                })
+              lpv <- parseSingleCabalFile root True pl
+              lp' <- loadLocalPackage False boptsCli targets (n, lpv)
               return $ PSFiles lp' loc
     sourceMap' <- Map.unions <$> sequence
       [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals

src/Stack/Build/Target.hs

@@ -80,7 +80,6 @@ import           Path.Extra (rejectMissingDir)
 import           Path.IO
 import           Stack.Config (getLocalPackages)
 import           Stack.Fetch (withCabalLoader)
-import           Stack.Package
 import           Stack.PackageIndex
 import           Stack.PackageLocation
 import           Stack.Snapshot (calculatePackagePromotion)
@@ -512,10 +511,8 @@ parseTargets needTargets boptscli = do
 
   (globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do
     addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do
-      bs <- loadSingleRawCabalFile loadFromIndex root loc
-      case rawParseGPD bs of
-        Left e -> throwIO $ InvalidCabalFileInLocal loc e bs
-        Right (_warnings, gpd) -> return (name, (gpd, loc, Nothing))
+      gpd <- parseSingleCabalFileIndex loadFromIndex root loc
+      return (name, (gpd, loc, Nothing))
 
     -- Calculate a list of all of the locals, based on the project
     -- packages, local dependencies, and added deps found from the

src/Stack/BuildPlan.hs

@@ -18,7 +18,6 @@ module Stack.BuildPlan
     , DepErrors
     , gpdPackageDeps
     , gpdPackages
-    , gpdPackageName
     , removeSrcPkgDefaultFlags
     , selectBestSnapshot
     , getToolMap
@@ -192,12 +191,6 @@ gpdPackages gpds = Map.fromList $
         fromCabalIdent (C.PackageIdentifier name version) =
             (fromCabalPackageName name, fromCabalVersion version)
 
-gpdPackageName :: GenericPackageDescription -> PackageName
-gpdPackageName = fromCabalPackageName
-    . C.pkgName
-    . C.package
-    . C.packageDescription
-
 gpdPackageDeps
     :: GenericPackageDescription
     -> CompilerVersion 'CVActual

src/Stack/Config.hs

@@ -45,7 +45,6 @@ module Stack.Config
   ,defaultConfigYaml
   ,getProjectConfig
   ,LocalConfigStatus(..)
-  ,getNamedComponents
   ) where
 
 import           Control.Monad.Extra (firstJustM)
@@ -54,12 +53,10 @@ import           Data.Aeson.Extended
 import qualified Data.ByteString as S
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
-import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Data.Text.Encoding (encodeUtf8)
 import qualified Data.Yaml as Yaml
 import qualified Distribution.PackageDescription as C
-import qualified Distribution.Types.UnqualComponentName as C
 import           Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
 import qualified Distribution.Text
 import           Distribution.Version (simplifyVersionRange, mkVersion')
@@ -80,7 +77,6 @@ import           Stack.Config.Urls
 import           Stack.Constants
 import           Stack.Fetch
 import qualified Stack.Image as Image
-import           Stack.Package
 import           Stack.PackageLocation
 import           Stack.Snapshot
 import           Stack.Types.BuildPlan
@@ -656,41 +652,17 @@ getLocalPackages = do
             bc <- view buildConfigL
 
             packages <- do
-              bss <- concat <$> mapM (loadMultiRawCabalFiles root) (bcPackages bc)
-              forM bss $ \(bs, loc) -> do
-                (warnings, gpd) <-
-                  case rawParseGPD bs of
-                    Left e -> throwM $ InvalidCabalFileInLocal (PLOther loc) e bs
-                    Right x -> return x
-                let PackageIdentifier name version =
-                           fromCabalPackageIdentifier
-                         $ C.package
-                         $ C.packageDescription gpd
-                dir <- resolveSinglePackageLocation root loc
-                cabalfp <- findOrGenerateCabalFile dir
-                mapM_ (printCabalFileWarning cabalfp) warnings
-                checkCabalFileName name cabalfp
-                let lpv = LocalPackageView
-                      { lpvVersion = version
-                      , lpvRoot = dir
-                      , lpvCabalFP = cabalfp
-                      , lpvComponents = getNamedComponents gpd
-                      , lpvGPD = gpd
-                      , lpvLoc = loc
-                      }
-                return (name, lpv)
-
-            deps <- mapM (loadMultiRawCabalFilesIndex loadFromIndex root) (bcDependencies bc)
-                >>= mapM (\(bs, loc :: PackageLocationIndex FilePath) -> do
-                     (_warnings, gpd) <- do
-                       case rawParseGPD bs of
-                         Left e -> throwM $ InvalidCabalFileInLocal loc e bs
-                         Right x -> return x
+              let withName lpv = (lpvName lpv, lpv)
+              map withName . concat <$> mapM (parseMultiCabalFiles root True) (bcPackages bc)
+
+            let wrapGPD (gpd, loc) =
                      let PackageIdentifier name _version =
                                 fromCabalPackageIdentifier
                               $ C.package
                               $ C.packageDescription gpd
-                     return (name, (gpd, loc))) . concat
+                      in (name, (gpd, loc))
+            deps <- (map wrapGPD . concat)
+                <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (bcDependencies bc)
 
             checkDuplicateNames $
               map (second (PLOther . lpvLoc)) packages ++
@@ -701,19 +673,6 @@ getLocalPackages = do
               , lpDependencies = Map.fromList deps
               }
 
-getNamedComponents :: C.GenericPackageDescription -> Set NamedComponent
-getNamedComponents gpkg = Set.fromList $ concat
-    [ maybe []  (const [CLib]) (C.condLibrary gpkg)
-    , go CExe   (map fst . C.condExecutables)
-    , go CTest  (map fst . C.condTestSuites)
-    , go CBench (map fst . C.condBenchmarks)
-    ]
-  where
-    go :: (T.Text -> NamedComponent)
-       -> (C.GenericPackageDescription -> [C.UnqualComponentName])
-       -> [NamedComponent]
-    go wrapper f = map (wrapper . T.pack . C.unUnqualComponentName) $ f gpkg
-
 -- | Check if there are any duplicate package names and, if so, throw an
 -- exception.
 checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m ()

src/Stack/Ghci.hs

@@ -566,7 +566,11 @@ makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets
             , packageConfigCompilerVersion = compilerVersion
             , packageConfigPlatform = view platformL econfig
             }
-    (warnings,gpkgdesc) <- readPackageUnresolved cabalfp
+    -- TODO we've already parsed this information, otherwise we
+    -- wouldn't have figured out the cabalfp already. In the future:
+    -- retain that GenericPackageDescription in the relevant data
+    -- structures to avoid reparsing.
+    (gpkgdesc, _cabalfp) <- readPackageUnresolvedDir (parent cabalfp) True
 
     -- Source the package's *.buildinfo file created by configure if any. See
     -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters
@@ -588,7 +592,6 @@ makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets
                     (C.updatePackageDescription bi y))
               mbuildinfo
 
-    mapM_ (printCabalFileWarning cabalfp) warnings
     (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals addPkgs cabalfp
     let filteredOpts = filterWanted opts
         filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted)

src/Stack/IDE.hs

@@ -14,7 +14,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Stack.Config (getLocalPackages)
-import           Stack.Package (findOrGenerateCabalFile)
+import           Stack.Package (readPackageUnresolvedDir, gpdPackageName)
 import           Stack.Prelude
 import           Stack.Types.Config
 import           Stack.Types.Package
@@ -28,9 +28,8 @@ listPackages = do
     -- the directory.
     packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages
     forM_ packageDirs $ \dir -> do
-        cabalfp <- findOrGenerateCabalFile dir
-        pkgName <- parsePackageNameFromFilePath cabalfp
-        (logInfo . packageNameText) pkgName
+        (gpd, _) <- readPackageUnresolvedDir dir False
+        (logInfo . packageNameText) (gpdPackageName gpd)
 
 -- | List the targets in the current project.
 listTargets :: HasEnvConfig env => RIO env ()

src/Stack/Init.hs

@@ -19,7 +19,8 @@ import           Data.List                       (intercalate, intersect,
                                                   maximumBy)
 import           Data.List.NonEmpty              (NonEmpty (..))
 import qualified Data.List.NonEmpty              as NonEmpty
-import qualified Data.Map                        as Map
+import qualified Data.Map.Strict                 as Map
+import qualified Data.Set                        as Set
 import qualified Data.Text                       as T
 import qualified Data.Yaml                       as Yaml
 import qualified Distribution.PackageDescription as C
@@ -68,11 +69,11 @@ initProject whichCmd currDir initOpts mresolver = do
     dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)
     let noPkgMsg =  "In order to init, you should have an existing .cabal \
                     \file. Please try \"stack new\" instead."
-        find  = findCabalFiles (includeSubDirs initOpts)
+        find  = findCabalDirs (includeSubDirs initOpts)
         dirs' = if null dirs then [currDir] else dirs
     logInfo "Looking for .cabal or package.yaml files to use to init the project."
-    cabalfps <- liftM concat $ mapM find dirs'
-    (bundle, dupPkgs)  <- cabalPackagesCheck cabalfps noPkgMsg Nothing
+    cabaldirs <- (Set.toList . Set.unions) <$> mapM find dirs'
+    (bundle, dupPkgs)  <- cabalPackagesCheck cabaldirs noPkgMsg Nothing
 
     (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts
                                                           mresolver bundle