1{-# LANGUAGE CPP #-} 2{-# LANGUAGE NoImplicitPrelude #-} 3{-# LANGUAGE TupleSections #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-# LANGUAGE FlexibleContexts #-} 6{-# LANGUAGE DataKinds #-} 7{-# LANGUAGE DeriveDataTypeable #-} 8{-# LANGUAGE FlexibleInstances #-} 9{-# LANGUAGE OverloadedStrings #-} 10{-# LANGUAGE RankNTypes #-} 11{-# LANGUAGE RecordWildCards #-} 12 13-- | Dealing with Cabal. 14 15module Stack.Package 16 (readDotBuildinfo 17 ,resolvePackage 18 ,packageFromPackageDescription 19 ,Package(..) 20 ,PackageDescriptionPair(..) 21 ,GetPackageFiles(..) 22 ,GetPackageOpts(..) 23 ,PackageConfig(..) 24 ,buildLogPath 25 ,PackageException (..) 26 ,resolvePackageDescription 27 ,packageDependencies 28 ,applyForceCustomBuild 29 ) where 30 31import Data.List (find, isPrefixOf, unzip) 32import qualified Data.Map.Strict as M 33import qualified Data.Set as S 34import qualified Data.Text as T 35import Distribution.Compiler 36import Distribution.ModuleName (ModuleName) 37import qualified Distribution.ModuleName as Cabal 38import qualified Distribution.Package as D 39import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) 40import qualified Distribution.PackageDescription as D 41import Distribution.PackageDescription hiding (FlagName) 42import Distribution.PackageDescription.Parsec 43import Distribution.Pretty (prettyShow) 44import Distribution.Simple.Glob (matchDirFileGlob) 45import Distribution.System (OS (..), Arch, Platform (..)) 46import qualified Distribution.Text as D 47import qualified Distribution.Types.CondTree as Cabal 48import qualified Distribution.Types.ExeDependency as Cabal 49import Distribution.Types.ForeignLib 50import qualified Distribution.Types.LegacyExeDependency as Cabal 51import Distribution.Types.LibraryName (libraryNameString, maybeToLibraryName) 52import Distribution.Types.MungedPackageName 53import qualified Distribution.Types.UnqualComponentName as Cabal 54import qualified Distribution.Verbosity as D 55import Distribution.Version (mkVersion, orLaterVersion, anyVersion) 56import qualified HiFileParser as Iface 57#if MIN_VERSION_path(0,7,0) 58import Path as FL hiding (replaceExtension) 59#else 60import Path as FL 61#endif 62import Path.Extra 63import Path.IO hiding (findFiles) 64import Stack.Build.Installed 65import Stack.Constants 66import Stack.Constants.Config 67import Stack.Prelude hiding (Display (..)) 68import Stack.Types.Compiler 69import Stack.Types.Config 70import Stack.Types.GhcPkgId 71import Stack.Types.NamedComponent 72import Stack.Types.Package 73import Stack.Types.Version 74import qualified System.Directory as D 75import System.FilePath (replaceExtension) 76import qualified System.FilePath as FilePath 77import System.IO.Error 78import RIO.Process 79import RIO.PrettyPrint 80import qualified RIO.PrettyPrint as PP (Style (Module)) 81 82data Ctx = Ctx { ctxFile :: !(Path Abs File) 83 , ctxDistDir :: !(Path Abs Dir) 84 , ctxBuildConfig :: !BuildConfig 85 , ctxCabalVer :: !Version 86 } 87 88instance HasPlatform Ctx 89instance HasGHCVariant Ctx 90instance HasLogFunc Ctx where 91 logFuncL = configL.logFuncL 92instance HasRunner Ctx where 93 runnerL = configL.runnerL 94instance HasStylesUpdate Ctx where 95 stylesUpdateL = runnerL.stylesUpdateL 96instance HasTerm Ctx where 97 useColorL = runnerL.useColorL 98 termWidthL = runnerL.termWidthL 99instance HasConfig Ctx 100instance HasPantryConfig Ctx where 101 pantryConfigL = configL.pantryConfigL 102instance HasProcessContext Ctx where 103 processContextL = configL.processContextL 104instance HasBuildConfig Ctx where 105 buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = y }) 106 107-- | Read @<package>.buildinfo@ ancillary files produced by some Setup.hs hooks. 108-- The file includes Cabal file syntax to be merged into the package description 109-- derived from the package's .cabal file. 110-- 111-- NOTE: not to be confused with BuildInfo, an Stack-internal datatype. 112readDotBuildinfo :: MonadIO m 113 => Path Abs File 114 -> m HookedBuildInfo 115readDotBuildinfo buildinfofp = 116 liftIO $ readHookedBuildInfo D.silent (toFilePath buildinfofp) 117 118-- | Resolve a parsed cabal file into a 'Package', which contains all of 119-- the info needed for stack to build the 'Package' given the current 120-- configuration. 121resolvePackage :: PackageConfig 122 -> GenericPackageDescription 123 -> Package 124resolvePackage packageConfig gpkg = 125 packageFromPackageDescription 126 packageConfig 127 (genPackageFlags gpkg) 128 (resolvePackageDescription packageConfig gpkg) 129 130packageFromPackageDescription :: PackageConfig 131 -> [D.Flag] 132 -> PackageDescriptionPair 133 -> Package 134packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkgNoMod pkg) = 135 Package 136 { packageName = name 137 , packageVersion = pkgVersion pkgId 138 , packageLicense = licenseRaw pkg 139 , packageDeps = deps 140 , packageFiles = pkgFiles 141 , packageUnknownTools = unknownTools 142 , packageGhcOptions = packageConfigGhcOptions packageConfig 143 , packageCabalConfigOpts = packageConfigCabalConfigOpts packageConfig 144 , packageFlags = packageConfigFlags packageConfig 145 , packageDefaultFlags = M.fromList 146 [(flagName flag, flagDefault flag) | flag <- pkgFlags] 147 , packageAllDeps = S.fromList (M.keys deps) 148 , packageLibraries = 149 let mlib = do 150 lib <- library pkg 151 guard $ buildable $ libBuildInfo lib 152 Just lib 153 in 154 case mlib of 155 Nothing -> NoLibraries 156 Just _ -> HasLibraries foreignLibNames 157 , packageInternalLibraries = subLibNames 158 , packageTests = M.fromList 159 [(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t) 160 | t <- testSuites pkgNoMod 161 , buildable (testBuildInfo t) 162 ] 163 , packageBenchmarks = S.fromList 164 [T.pack (Cabal.unUnqualComponentName $ benchmarkName b) 165 | b <- benchmarks pkgNoMod 166 , buildable (benchmarkBuildInfo b) 167 ] 168 -- Same comment about buildable applies here too. 169 , packageExes = S.fromList 170 [T.pack (Cabal.unUnqualComponentName $ exeName biBuildInfo) 171 | biBuildInfo <- executables pkg 172 , buildable (buildInfo biBuildInfo)] 173 -- This is an action used to collect info needed for "stack ghci". 174 -- This info isn't usually needed, so computation of it is deferred. 175 , packageOpts = GetPackageOpts $ 176 \installMap installedMap omitPkgs addPkgs cabalfp -> 177 do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp 178 let internals = S.toList $ internalLibComponents $ M.keysSet componentsModules 179 excludedInternals <- mapM (parsePackageNameThrowing . T.unpack) internals 180 mungedInternals <- mapM (parsePackageNameThrowing . T.unpack . 181 toInternalPackageMungedName) internals 182 componentsOpts <- 183 generatePkgDescOpts installMap installedMap 184 (excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs) 185 cabalfp pkg componentFiles 186 return (componentsModules,componentFiles,componentsOpts) 187 , packageHasExposedModules = maybe 188 False 189 (not . null . exposedModules) 190 (library pkg) 191 , packageBuildType = buildType pkg 192 , packageSetupDeps = msetupDeps 193 , packageCabalSpec = either orLaterVersion id $ specVersionRaw pkg 194 } 195 where 196 extraLibNames = S.union subLibNames foreignLibNames 197 198 subLibNames 199 = S.fromList 200 $ map (T.pack . Cabal.unUnqualComponentName) 201 $ mapMaybe (libraryNameString . libName) -- this is a design bug in the Cabal API: this should statically be known to exist 202 $ filter (buildable . libBuildInfo) 203 $ subLibraries pkg 204 205 foreignLibNames 206 = S.fromList 207 $ map (T.pack . Cabal.unUnqualComponentName . foreignLibName) 208 $ filter (buildable . foreignLibBuildInfo) 209 $ foreignLibs pkg 210 211 toInternalPackageMungedName 212 = T.pack . prettyShow . MungedPackageName (pkgName pkgId) 213 . maybeToLibraryName . Just . Cabal.mkUnqualComponentName . T.unpack 214 215 -- Gets all of the modules, files, build files, and data files that 216 -- constitute the package. This is primarily used for dirtiness 217 -- checking during build, as well as use by "stack ghci" 218 pkgFiles = GetPackageFiles $ 219 \cabalfp -> debugBracket ("getPackageFiles" <+> pretty cabalfp) $ do 220 let pkgDir = parent cabalfp 221 distDir <- distDirFromDir pkgDir 222 bc <- view buildConfigL 223 cabalVer <- view cabalVersionL 224 (componentModules,componentFiles,dataFiles',warnings) <- 225 runRIO 226 (Ctx cabalfp distDir bc cabalVer) 227 (packageDescModulesAndFiles pkg) 228 setupFiles <- 229 if buildType pkg == Custom 230 then do 231 let setupHsPath = pkgDir </> relFileSetupHs 232 setupLhsPath = pkgDir </> relFileSetupLhs 233 setupHsExists <- doesFileExist setupHsPath 234 if setupHsExists then return (S.singleton setupHsPath) else do 235 setupLhsExists <- doesFileExist setupLhsPath 236 if setupLhsExists then return (S.singleton setupLhsPath) else return S.empty 237 else return S.empty 238 buildFiles <- liftM (S.insert cabalfp . S.union setupFiles) $ do 239 let hpackPath = pkgDir </> relFileHpackPackageConfig 240 hpackExists <- doesFileExist hpackPath 241 return $ if hpackExists then S.singleton hpackPath else S.empty 242 return (componentModules, componentFiles, buildFiles <> dataFiles', warnings) 243 pkgId = package pkg 244 name = pkgName pkgId 245 246 (unknownTools, knownTools) = packageDescTools pkg 247 248 deps = M.filterWithKey (const . not . isMe) (M.unionsWith (<>) 249 [ asLibrary <$> packageDependencies packageConfig pkg 250 -- We include all custom-setup deps - if present - in the 251 -- package deps themselves. Stack always works with the 252 -- invariant that there will be a single installed package 253 -- relating to a package name, and this applies at the setup 254 -- dependency level as well. 255 , asLibrary <$> fromMaybe M.empty msetupDeps 256 , knownTools 257 ]) 258 msetupDeps = fmap 259 (M.fromList . map (depPkgName &&& depVerRange) . setupDepends) 260 (setupBuildInfo pkg) 261 262 asLibrary range = DepValue 263 { dvVersionRange = range 264 , dvType = AsLibrary 265 } 266 267 -- Is the package dependency mentioned here me: either the package 268 -- name itself, or the name of one of the sub libraries 269 isMe name' = name' == name || fromString (packageNameString name') `S.member` extraLibNames 270 271-- | Generate GHC options for the package's components, and a list of 272-- options which apply generally to the package, not one specific 273-- component. 274generatePkgDescOpts 275 :: (HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m) 276 => InstallMap 277 -> InstalledMap 278 -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags 279 -> [PackageName] -- ^ Packages to add to the "-package" flags 280 -> Path Abs File 281 -> PackageDescription 282 -> Map NamedComponent [DotCabalPath] 283 -> m (Map NamedComponent BuildInfoOpts) 284generatePkgDescOpts installMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do 285 config <- view configL 286 cabalVer <- view cabalVersionL 287 distDir <- distDirFromDir cabalDir 288 let generate namedComponent binfo = 289 ( namedComponent 290 , generateBuildInfoOpts BioInput 291 { biInstallMap = installMap 292 , biInstalledMap = installedMap 293 , biCabalDir = cabalDir 294 , biDistDir = distDir 295 , biOmitPackages = omitPkgs 296 , biAddPackages = addPkgs 297 , biBuildInfo = binfo 298 , biDotCabalPaths = fromMaybe [] (M.lookup namedComponent componentPaths) 299 , biConfigLibDirs = configExtraLibDirs config 300 , biConfigIncludeDirs = configExtraIncludeDirs config 301 , biComponentName = namedComponent 302 , biCabalVersion = cabalVer 303 } 304 ) 305 return 306 ( M.fromList 307 (concat 308 [ maybe 309 [] 310 (return . generate CLib . libBuildInfo) 311 (library pkg) 312 , mapMaybe 313 (\sublib -> do 314 let maybeLib = CInternalLib . T.pack . Cabal.unUnqualComponentName <$> (libraryNameString . libName) sublib 315 flip generate (libBuildInfo sublib) <$> maybeLib 316 ) 317 (subLibraries pkg) 318 , fmap 319 (\exe -> 320 generate 321 (CExe (T.pack (Cabal.unUnqualComponentName (exeName exe)))) 322 (buildInfo exe)) 323 (executables pkg) 324 , fmap 325 (\bench -> 326 generate 327 (CBench (T.pack (Cabal.unUnqualComponentName (benchmarkName bench)))) 328 (benchmarkBuildInfo bench)) 329 (benchmarks pkg) 330 , fmap 331 (\test -> 332 generate 333 (CTest (T.pack (Cabal.unUnqualComponentName (testName test)))) 334 (testBuildInfo test)) 335 (testSuites pkg)])) 336 where 337 cabalDir = parent cabalfp 338 339-- | Input to 'generateBuildInfoOpts' 340data BioInput = BioInput 341 { biInstallMap :: !InstallMap 342 , biInstalledMap :: !InstalledMap 343 , biCabalDir :: !(Path Abs Dir) 344 , biDistDir :: !(Path Abs Dir) 345 , biOmitPackages :: ![PackageName] 346 , biAddPackages :: ![PackageName] 347 , biBuildInfo :: !BuildInfo 348 , biDotCabalPaths :: ![DotCabalPath] 349 , biConfigLibDirs :: ![FilePath] 350 , biConfigIncludeDirs :: ![FilePath] 351 , biComponentName :: !NamedComponent 352 , biCabalVersion :: !Version 353 } 354 355-- | Generate GHC options for the target. Since Cabal also figures out 356-- these options, currently this is only used for invoking GHCI (via 357-- stack ghci). 358generateBuildInfoOpts :: BioInput -> BuildInfoOpts 359generateBuildInfoOpts BioInput {..} = 360 BuildInfoOpts 361 { bioOpts = ghcOpts ++ cppOptions biBuildInfo 362 -- NOTE for future changes: Due to this use of nubOrd (and other uses 363 -- downstream), these generated options must not rely on multiple 364 -- argument sequences. For example, ["--main-is", "Foo.hs", "--main- 365 -- is", "Bar.hs"] would potentially break due to the duplicate 366 -- "--main-is" being removed. 367 -- 368 -- See https://github.com/commercialhaskell/stack/issues/1255 369 , bioOneWordOpts = nubOrd $ concat 370 [extOpts, srcOpts, includeOpts, libOpts, fworks, cObjectFiles] 371 , bioPackageFlags = deps 372 , bioCabalMacros = componentAutogen </> relFileCabalMacrosH 373 } 374 where 375 cObjectFiles = 376 mapMaybe (fmap toFilePath . 377 makeObjectFilePathFromC biCabalDir biComponentName biDistDir) 378 cfiles 379 cfiles = mapMaybe dotCabalCFilePath biDotCabalPaths 380 installVersion = snd 381 -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ... 382 deps = 383 concat 384 [ case M.lookup name biInstalledMap of 385 Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid] 386 _ -> ["-package=" <> packageNameString name <> 387 maybe "" -- This empty case applies to e.g. base. 388 ((("-" <>) . versionString) . installVersion) 389 (M.lookup name biInstallMap)] 390 | name <- pkgs] 391 pkgs = 392 biAddPackages ++ 393 [ name 394 | Dependency name _ _ <- targetBuildDepends biBuildInfo -- TODO: cabal 3 introduced multiple public libraries in a single dependency 395 , name `notElem` biOmitPackages] 396 PerCompilerFlavor ghcOpts _ = options biBuildInfo 397 extOpts = map (("-X" ++) . D.display) (usedExtensions biBuildInfo) 398 srcOpts = 399 map (("-i" <>) . toFilePathNoTrailingSep) 400 (concat 401 [ [ componentBuildDir biCabalVersion biComponentName biDistDir ] 402 , [ biCabalDir 403 | null (hsSourceDirs biBuildInfo) 404 ] 405 , mapMaybe toIncludeDir (hsSourceDirs biBuildInfo) 406 , [ componentAutogen ] 407 , maybeToList (packageAutogenDir biCabalVersion biDistDir) 408 , [ componentOutputDir biComponentName biDistDir ] 409 ]) ++ 410 [ "-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir) ] 411 componentAutogen = componentAutogenDir biCabalVersion biComponentName biDistDir 412 toIncludeDir "." = Just biCabalDir 413 toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir 414 includeOpts = 415 map ("-I" <>) (biConfigIncludeDirs <> pkgIncludeOpts) 416 pkgIncludeOpts = 417 [ toFilePathNoTrailingSep absDir 418 | dir <- includeDirs biBuildInfo 419 , absDir <- handleDir dir 420 ] 421 libOpts = 422 map ("-l" <>) (extraLibs biBuildInfo) <> 423 map ("-L" <>) (biConfigLibDirs <> pkgLibDirs) 424 pkgLibDirs = 425 [ toFilePathNoTrailingSep absDir 426 | dir <- extraLibDirs biBuildInfo 427 , absDir <- handleDir dir 428 ] 429 handleDir dir = case (parseAbsDir dir, parseRelDir dir) of 430 (Just ab, _ ) -> [ab] 431 (_ , Just rel) -> [biCabalDir </> rel] 432 (Nothing, Nothing ) -> [] 433 fworks = map (\fwk -> "-framework=" <> fwk) (frameworks biBuildInfo) 434 435-- | Make the .o path from the .c file path for a component. Example: 436-- 437-- @ 438-- executable FOO 439-- c-sources: cbits/text_search.c 440-- @ 441-- 442-- Produces 443-- 444-- <dist-dir>/build/FOO/FOO-tmp/cbits/text_search.o 445-- 446-- Example: 447-- 448-- λ> makeObjectFilePathFromC 449-- $(mkAbsDir "/Users/chris/Repos/hoogle") 450-- CLib 451-- $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist") 452-- $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c") 453-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/cbits/text_search.o" 454-- λ> makeObjectFilePathFromC 455-- $(mkAbsDir "/Users/chris/Repos/hoogle") 456-- (CExe "hoogle") 457-- $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist") 458-- $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c") 459-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/hoogle/hoogle-tmp/cbits/text_search.o" 460-- λ> 461makeObjectFilePathFromC 462 :: MonadThrow m 463 => Path Abs Dir -- ^ The cabal directory. 464 -> NamedComponent -- ^ The name of the component. 465 -> Path Abs Dir -- ^ Dist directory. 466 -> Path Abs File -- ^ The path to the .c file. 467 -> m (Path Abs File) -- ^ The path to the .o file for the component. 468makeObjectFilePathFromC cabalDir namedComponent distDir cFilePath = do 469 relCFilePath <- stripProperPrefix cabalDir cFilePath 470 relOFilePath <- 471 parseRelFile (replaceExtension (toFilePath relCFilePath) "o") 472 return (componentOutputDir namedComponent distDir </> relOFilePath) 473 474-- | Make the global autogen dir if Cabal version is new enough. 475packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir) 476packageAutogenDir cabalVer distDir 477 | cabalVer < mkVersion [2, 0] = Nothing 478 | otherwise = Just $ buildDir distDir </> relDirGlobalAutogen 479 480-- | Make the autogen dir. 481componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir 482componentAutogenDir cabalVer component distDir = 483 componentBuildDir cabalVer component distDir </> relDirAutogen 484 485-- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir' 486componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir 487componentBuildDir cabalVer component distDir 488 | cabalVer < mkVersion [2, 0] = buildDir distDir 489 | otherwise = 490 case component of 491 CLib -> buildDir distDir 492 CInternalLib name -> buildDir distDir </> componentNameToDir name 493 CExe name -> buildDir distDir </> componentNameToDir name 494 CTest name -> buildDir distDir </> componentNameToDir name 495 CBench name -> buildDir distDir </> componentNameToDir name 496 497-- | The directory where generated files are put like .o or .hs (from .x files). 498componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir 499componentOutputDir namedComponent distDir = 500 case namedComponent of 501 CLib -> buildDir distDir 502 CInternalLib name -> makeTmp name 503 CExe name -> makeTmp name 504 CTest name -> makeTmp name 505 CBench name -> makeTmp name 506 where 507 makeTmp name = 508 buildDir distDir </> componentNameToDir (name <> "/" <> name <> "-tmp") 509 510-- | Make the build dir. Note that Cabal >= 2.0 uses the 511-- 'componentBuildDir' above for some things. 512buildDir :: Path Abs Dir -> Path Abs Dir 513buildDir distDir = distDir </> relDirBuild 514 515-- NOTE: don't export this, only use it for valid paths based on 516-- component names. 517componentNameToDir :: Text -> Path Rel Dir 518componentNameToDir name = 519 fromMaybe (error "Invariant violated: component names should always parse as directory names") 520 (parseRelDir (T.unpack name)) 521 522-- | Get all dependencies of the package (buildable targets only). 523-- 524-- Note that for Cabal versions 1.22 and earlier, there is a bug where 525-- Cabal requires dependencies for non-buildable components to be 526-- present. We're going to use GHC version as a proxy for Cabal 527-- library version in this case for simplicity, so we'll check for GHC 528-- being 7.10 or earlier. This obviously makes our function a lot more 529-- fun to write... 530packageDependencies 531 :: PackageConfig 532 -> PackageDescription 533 -> Map PackageName VersionRange 534packageDependencies pkgConfig pkg' = 535 M.fromListWith intersectVersionRanges $ 536 map (depPkgName &&& depVerRange) $ 537 concatMap targetBuildDepends (allBuildInfo' pkg) ++ 538 maybe [] setupDepends (setupBuildInfo pkg) 539 where 540 pkg 541 | getGhcVersion (packageConfigCompilerVersion pkgConfig) >= mkVersion [8, 0] = pkg' 542 -- Set all components to buildable. Only need to worry about 543 -- library, exe, test, and bench, since others didn't exist in 544 -- older Cabal versions 545 | otherwise = pkg' 546 { library = (\c -> c { libBuildInfo = go (libBuildInfo c) }) <$> library pkg' 547 , executables = (\c -> c { buildInfo = go (buildInfo c) }) <$> executables pkg' 548 , testSuites = 549 if packageConfigEnableTests pkgConfig 550 then (\c -> c { testBuildInfo = go (testBuildInfo c) }) <$> testSuites pkg' 551 else testSuites pkg' 552 , benchmarks = 553 if packageConfigEnableBenchmarks pkgConfig 554 then (\c -> c { benchmarkBuildInfo = go (benchmarkBuildInfo c) }) <$> benchmarks pkg' 555 else benchmarks pkg' 556 } 557 558 go bi = bi { buildable = True } 559 560-- | Get all dependencies of the package (buildable targets only). 561-- 562-- This uses both the new 'buildToolDepends' and old 'buildTools' 563-- information. 564packageDescTools 565 :: PackageDescription 566 -> (Set ExeName, Map PackageName DepValue) 567packageDescTools pd = 568 (S.fromList $ concat unknowns, M.fromListWith (<>) $ concat knowns) 569 where 570 (unknowns, knowns) = unzip $ map perBI $ allBuildInfo' pd 571 572 perBI :: BuildInfo -> ([ExeName], [(PackageName, DepValue)]) 573 perBI bi = 574 (unknownTools, tools) 575 where 576 (unknownTools, knownTools) = partitionEithers $ map go1 (buildTools bi) 577 578 tools = mapMaybe go2 (knownTools ++ buildToolDepends bi) 579 580 -- This is similar to desugarBuildTool from Cabal, however it 581 -- uses our own hard-coded map which drops tools shipped with 582 -- GHC (like hsc2hs), and includes some tools from Stackage. 583 go1 :: Cabal.LegacyExeDependency -> Either ExeName Cabal.ExeDependency 584 go1 (Cabal.LegacyExeDependency name range) = 585 case M.lookup name hardCodedMap of 586 Just pkgName -> Right $ Cabal.ExeDependency pkgName (Cabal.mkUnqualComponentName name) range 587 Nothing -> Left $ ExeName $ T.pack name 588 589 go2 :: Cabal.ExeDependency -> Maybe (PackageName, DepValue) 590 go2 (Cabal.ExeDependency pkg _name range) 591 | pkg `S.member` preInstalledPackages = Nothing 592 | otherwise = Just 593 ( pkg 594 , DepValue 595 { dvVersionRange = range 596 , dvType = AsBuildTool 597 } 598 ) 599 600-- | A hard-coded map for tool dependencies 601hardCodedMap :: Map String D.PackageName 602hardCodedMap = M.fromList 603 [ ("alex", Distribution.Package.mkPackageName "alex") 604 , ("happy", Distribution.Package.mkPackageName "happy") 605 , ("cpphs", Distribution.Package.mkPackageName "cpphs") 606 , ("greencard", Distribution.Package.mkPackageName "greencard") 607 , ("c2hs", Distribution.Package.mkPackageName "c2hs") 608 , ("hscolour", Distribution.Package.mkPackageName "hscolour") 609 , ("hspec-discover", Distribution.Package.mkPackageName "hspec-discover") 610 , ("hsx2hs", Distribution.Package.mkPackageName "hsx2hs") 611 , ("gtk2hsC2hs", Distribution.Package.mkPackageName "gtk2hs-buildtools") 612 , ("gtk2hsHookGenerator", Distribution.Package.mkPackageName "gtk2hs-buildtools") 613 , ("gtk2hsTypeGen", Distribution.Package.mkPackageName "gtk2hs-buildtools") 614 ] 615 616-- | Executable-only packages which come pre-installed with GHC and do 617-- not need to be built. Without this exception, we would either end 618-- up unnecessarily rebuilding these packages, or failing because the 619-- packages do not appear in the Stackage snapshot. 620preInstalledPackages :: Set D.PackageName 621preInstalledPackages = S.fromList 622 [ D.mkPackageName "hsc2hs" 623 , D.mkPackageName "haddock" 624 ] 625 626-- | Variant of 'allBuildInfo' from Cabal that, like versions before 627-- 2.2, only includes buildable components. 628allBuildInfo' :: PackageDescription -> [BuildInfo] 629allBuildInfo' pkg_descr = [ bi | lib <- allLibraries pkg_descr 630 , let bi = libBuildInfo lib 631 , buildable bi ] 632 ++ [ bi | flib <- foreignLibs pkg_descr 633 , let bi = foreignLibBuildInfo flib 634 , buildable bi ] 635 ++ [ bi | exe <- executables pkg_descr 636 , let bi = buildInfo exe 637 , buildable bi ] 638 ++ [ bi | tst <- testSuites pkg_descr 639 , let bi = testBuildInfo tst 640 , buildable bi ] 641 ++ [ bi | tst <- benchmarks pkg_descr 642 , let bi = benchmarkBuildInfo tst 643 , buildable bi ] 644 645-- | Get all files referenced by the package. 646packageDescModulesAndFiles 647 :: PackageDescription 648 -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent [DotCabalPath], Set (Path Abs File), [PackageWarning]) 649packageDescModulesAndFiles pkg = do 650 (libraryMods,libDotCabalFiles,libWarnings) <- 651 maybe 652 (return (M.empty, M.empty, [])) 653 (asModuleAndFileMap libComponent libraryFiles) 654 (library pkg) 655 (subLibrariesMods,subLibDotCabalFiles,subLibWarnings) <- 656 liftM 657 foldTuples 658 (mapM 659 (asModuleAndFileMap internalLibComponent libraryFiles) 660 (subLibraries pkg)) 661 (executableMods,exeDotCabalFiles,exeWarnings) <- 662 liftM 663 foldTuples 664 (mapM 665 (asModuleAndFileMap exeComponent executableFiles) 666 (executables pkg)) 667 (testMods,testDotCabalFiles,testWarnings) <- 668 liftM 669 foldTuples 670 (mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg)) 671 (benchModules,benchDotCabalPaths,benchWarnings) <- 672 liftM 673 foldTuples 674 (mapM 675 (asModuleAndFileMap benchComponent benchmarkFiles) 676 (benchmarks pkg)) 677 dfiles <- resolveGlobFiles (specVersion pkg) 678 (extraSrcFiles pkg 679 ++ map (dataDir pkg FilePath.</>) (dataFiles pkg)) 680 let modules = libraryMods <> subLibrariesMods <> executableMods <> testMods <> benchModules 681 files = 682 libDotCabalFiles <> subLibDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <> 683 benchDotCabalPaths 684 warnings = libWarnings <> subLibWarnings <> exeWarnings <> testWarnings <> benchWarnings 685 return (modules, files, dfiles, warnings) 686 where 687 libComponent = const CLib 688 internalLibComponent = CInternalLib . T.pack . maybe "" Cabal.unUnqualComponentName . libraryNameString . libName 689 exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName 690 testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName 691 benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName 692 asModuleAndFileMap label f lib = do 693 (a,b,c) <- f (label lib) lib 694 return (M.singleton (label lib) a, M.singleton (label lib) b, c) 695 foldTuples = foldl' (<>) (M.empty, M.empty, []) 696 697-- | Resolve globbing of files (e.g. data files) to absolute paths. 698resolveGlobFiles 699 :: Version -- ^ cabal file version 700 -> [String] 701 -> RIO Ctx (Set (Path Abs File)) 702resolveGlobFiles cabalFileVersion = 703 liftM (S.fromList . catMaybes . concat) . 704 mapM resolve 705 where 706 resolve name = 707 if '*' `elem` name 708 then explode name 709 else liftM return (resolveFileOrWarn name) 710 explode name = do 711 dir <- asks (parent . ctxFile) 712 names <- 713 matchDirFileGlob' 714 (FL.toFilePath dir) 715 name 716 mapM resolveFileOrWarn names 717 matchDirFileGlob' dir glob = 718 catch 719 (liftIO (matchDirFileGlob minBound cabalFileVersion dir glob)) 720 (\(e :: IOException) -> 721 if isUserError e 722 then do 723 prettyWarnL 724 [ flow "Wildcard does not match any files:" 725 , style File $ fromString glob 726 , line <> flow "in directory:" 727 , style Dir $ fromString dir 728 ] 729 return [] 730 else throwIO e) 731 732-- | Get all files referenced by the benchmark. 733benchmarkFiles 734 :: NamedComponent 735 -> Benchmark 736 -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) 737benchmarkFiles component bench = do 738 resolveComponentFiles component build names 739 where 740 names = bnames <> exposed 741 exposed = 742 case benchmarkInterface bench of 743 BenchmarkExeV10 _ fp -> [DotCabalMain fp] 744 BenchmarkUnsupported _ -> [] 745 bnames = map DotCabalModule (otherModules build) 746 build = benchmarkBuildInfo bench 747 748-- | Get all files referenced by the test. 749testFiles 750 :: NamedComponent 751 -> TestSuite 752 -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) 753testFiles component test = do 754 resolveComponentFiles component build names 755 where 756 names = bnames <> exposed 757 exposed = 758 case testInterface test of 759 TestSuiteExeV10 _ fp -> [DotCabalMain fp] 760 TestSuiteLibV09 _ mn -> [DotCabalModule mn] 761 TestSuiteUnsupported _ -> [] 762 bnames = map DotCabalModule (otherModules build) 763 build = testBuildInfo test 764 765-- | Get all files referenced by the executable. 766executableFiles 767 :: NamedComponent 768 -> Executable 769 -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) 770executableFiles component exe = do 771 resolveComponentFiles component build names 772 where 773 build = buildInfo exe 774 names = 775 map DotCabalModule (otherModules build) ++ 776 [DotCabalMain (modulePath exe)] 777 778-- | Get all files referenced by the library. 779libraryFiles 780 :: NamedComponent 781 -> Library 782 -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) 783libraryFiles component lib = do 784 resolveComponentFiles component build names 785 where 786 build = libBuildInfo lib 787 names = bnames ++ exposed 788 exposed = map DotCabalModule (exposedModules lib) 789 bnames = map DotCabalModule (otherModules build) 790 791-- | Get all files referenced by the component. 792resolveComponentFiles 793 :: NamedComponent 794 -> BuildInfo 795 -> [DotCabalDescriptor] 796 -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) 797resolveComponentFiles component build names = do 798 dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) 799 dir <- asks (parent . ctxFile) 800 agdirs <- autogenDirs 801 (modules,files,warnings) <- 802 resolveFilesAndDeps 803 component 804 ((if null dirs then [dir] else dirs) ++ agdirs) 805 names 806 cfiles <- buildOtherSources build 807 return (modules, files <> cfiles, warnings) 808 where 809 autogenDirs = do 810 cabalVer <- asks ctxCabalVer 811 distDir <- asks ctxDistDir 812 let compDir = componentAutogenDir cabalVer component distDir 813 pkgDir = maybeToList $ packageAutogenDir cabalVer distDir 814 filterM doesDirExist $ compDir : pkgDir 815 816-- | Get all C sources and extra source files in a build. 817buildOtherSources :: BuildInfo -> RIO Ctx [DotCabalPath] 818buildOtherSources build = do 819 cwd <- liftIO getCurrentDir 820 dir <- asks (parent . ctxFile) 821 file <- asks ctxFile 822 let resolveDirFiles files toCabalPath = 823 forMaybeM files $ \fp -> do 824 result <- resolveDirFile dir fp 825 case result of 826 Nothing -> do 827 warnMissingFile "File" cwd fp file 828 return Nothing 829 Just p -> return $ Just (toCabalPath p) 830 csources <- resolveDirFiles (cSources build) DotCabalCFilePath 831 jsources <- resolveDirFiles (targetJsSources build) DotCabalFilePath 832 return (csources <> jsources) 833 834-- | Get the target's JS sources. 835targetJsSources :: BuildInfo -> [FilePath] 836targetJsSources = jsSources 837 838-- | A pair of package descriptions: one which modified the buildable 839-- values of test suites and benchmarks depending on whether they are 840-- enabled, and one which does not. 841-- 842-- Fields are intentionally lazy, we may only need one or the other 843-- value. 844-- 845-- MSS 2017-08-29: The very presence of this data type is terribly 846-- ugly, it represents the fact that the Cabal 2.0 upgrade did _not_ 847-- go well. Specifically, we used to have a field to indicate whether 848-- a component was enabled in addition to buildable, but that's gone 849-- now, and this is an ugly proxy. We should at some point clean up 850-- the mess of Package, LocalPackage, etc, and probably pull in the 851-- definition of PackageDescription from Cabal with our additionally 852-- needed metadata. But this is a good enough hack for the 853-- moment. Odds are, you're reading this in the year 2024 and thinking 854-- "wtf?" 855data PackageDescriptionPair = PackageDescriptionPair 856 { pdpOrigBuildable :: PackageDescription 857 , pdpModifiedBuildable :: PackageDescription 858 } 859 860-- | Evaluates the conditions of a 'GenericPackageDescription', yielding 861-- a resolved 'PackageDescription'. 862resolvePackageDescription :: PackageConfig 863 -> GenericPackageDescription 864 -> PackageDescriptionPair 865resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib subLibs foreignLibs' exes tests benches) = 866 PackageDescriptionPair 867 { pdpOrigBuildable = go False 868 , pdpModifiedBuildable = go True 869 } 870 where 871 go modBuildable = 872 desc {library = 873 fmap (resolveConditions rc updateLibDeps) mlib 874 ,subLibraries = 875 map (\(n, v) -> (resolveConditions rc updateLibDeps v){libName=LSubLibName n}) 876 subLibs 877 ,foreignLibs = 878 map (\(n, v) -> (resolveConditions rc updateForeignLibDeps v){foreignLibName=n}) 879 foreignLibs' 880 ,executables = 881 map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n}) 882 exes 883 ,testSuites = 884 map (\(n,v) -> (resolveConditions rc (updateTestDeps modBuildable) v){testName=n}) 885 tests 886 ,benchmarks = 887 map (\(n,v) -> (resolveConditions rc (updateBenchmarkDeps modBuildable) v){benchmarkName=n}) 888 benches} 889 890 flags = 891 M.union (packageConfigFlags packageConfig) 892 (flagMap defaultFlags) 893 894 rc = mkResolveConditions 895 (packageConfigCompilerVersion packageConfig) 896 (packageConfigPlatform packageConfig) 897 flags 898 899 updateLibDeps lib deps = 900 lib {libBuildInfo = 901 (libBuildInfo lib) {targetBuildDepends = deps}} 902 updateForeignLibDeps lib deps = 903 lib {foreignLibBuildInfo = 904 (foreignLibBuildInfo lib) {targetBuildDepends = deps}} 905 updateExeDeps exe deps = 906 exe {buildInfo = 907 (buildInfo exe) {targetBuildDepends = deps}} 908 909 -- Note that, prior to moving to Cabal 2.0, we would set 910 -- testEnabled/benchmarkEnabled here. These fields no longer 911 -- exist, so we modify buildable instead here. The only 912 -- wrinkle in the Cabal 2.0 story is 913 -- https://github.com/haskell/cabal/issues/1725, where older 914 -- versions of Cabal (which may be used for actually building 915 -- code) don't properly exclude build-depends for 916 -- non-buildable components. Testing indicates that everything 917 -- is working fine, and that this comment can be completely 918 -- ignored. I'm leaving the comment anyway in case something 919 -- breaks and you, poor reader, are investigating. 920 updateTestDeps modBuildable test deps = 921 let bi = testBuildInfo test 922 bi' = bi 923 { targetBuildDepends = deps 924 , buildable = buildable bi && (if modBuildable then packageConfigEnableTests packageConfig else True) 925 } 926 in test { testBuildInfo = bi' } 927 updateBenchmarkDeps modBuildable benchmark deps = 928 let bi = benchmarkBuildInfo benchmark 929 bi' = bi 930 { targetBuildDepends = deps 931 , buildable = buildable bi && (if modBuildable then packageConfigEnableBenchmarks packageConfig else True) 932 } 933 in benchmark { benchmarkBuildInfo = bi' } 934 935-- | Make a map from a list of flag specifications. 936-- 937-- What is @flagManual@ for? 938flagMap :: [Flag] -> Map FlagName Bool 939flagMap = M.fromList . map pair 940 where pair :: Flag -> (FlagName, Bool) 941 pair = flagName &&& flagDefault 942 943data ResolveConditions = ResolveConditions 944 { rcFlags :: Map FlagName Bool 945 , rcCompilerVersion :: ActualCompiler 946 , rcOS :: OS 947 , rcArch :: Arch 948 } 949 950-- | Generic a @ResolveConditions@ using sensible defaults. 951mkResolveConditions :: ActualCompiler -- ^ Compiler version 952 -> Platform -- ^ installation target platform 953 -> Map FlagName Bool -- ^ enabled flags 954 -> ResolveConditions 955mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions 956 { rcFlags = flags 957 , rcCompilerVersion = compilerVersion 958 , rcOS = os 959 , rcArch = arch 960 } 961 962-- | Resolve the condition tree for the library. 963resolveConditions :: (Semigroup target,Monoid target,Show target) 964 => ResolveConditions 965 -> (target -> cs -> target) 966 -> CondTree ConfVar cs target 967 -> target 968resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children 969 where basic = addDeps lib deps 970 children = mconcat (map apply cs) 971 where apply (Cabal.CondBranch cond node mcs) = 972 if condSatisfied cond 973 then resolveConditions rc addDeps node 974 else maybe mempty (resolveConditions rc addDeps) mcs 975 condSatisfied c = 976 case c of 977 Var v -> varSatisifed v 978 Lit b -> b 979 CNot c' -> 980 not (condSatisfied c') 981 COr cx cy -> 982 condSatisfied cx || condSatisfied cy 983 CAnd cx cy -> 984 condSatisfied cx && condSatisfied cy 985 varSatisifed v = 986 case v of 987 OS os -> os == rcOS rc 988 Arch arch -> arch == rcArch rc 989 Flag flag -> 990 fromMaybe False $ M.lookup flag (rcFlags rc) 991 -- NOTE: ^^^^^ This should never happen, as all flags 992 -- which are used must be declared. Defaulting to 993 -- False. 994 Impl flavor range -> 995 case (flavor, rcCompilerVersion rc) of 996 (GHC, ACGhc vghc) -> vghc `withinRange` range 997 _ -> False 998 999-- | Try to resolve the list of base names in the given directory by 1000-- looking for unique instances of base names applied with the given 1001-- extensions, plus find any of their module and TemplateHaskell 1002-- dependencies. 1003resolveFilesAndDeps 1004 :: NamedComponent -- ^ Package component name 1005 -> [Path Abs Dir] -- ^ Directories to look in. 1006 -> [DotCabalDescriptor] -- ^ Base names. 1007 -> RIO Ctx (Map ModuleName (Path Abs File),[DotCabalPath],[PackageWarning]) 1008resolveFilesAndDeps component dirs names0 = do 1009 (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty 1010 warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules) 1011 return (foundModules, dotCabalPaths, warnings) 1012 where 1013 loop [] _ = return ([], M.empty, []) 1014 loop names doneModules0 = do 1015 resolved <- resolveFiles dirs names 1016 let foundFiles = mapMaybe snd resolved 1017 foundModules = mapMaybe toResolvedModule resolved 1018 missingModules = mapMaybe toMissingModule resolved 1019 pairs <- mapM (getDependencies component dirs) foundFiles 1020 let doneModules = 1021 S.union 1022 doneModules0 1023 (S.fromList (mapMaybe dotCabalModule names)) 1024 moduleDeps = S.unions (map fst pairs) 1025 thDepFiles = concatMap snd pairs 1026 modulesRemaining = S.difference moduleDeps doneModules 1027 -- Ignore missing modules discovered as dependencies - they may 1028 -- have been deleted. 1029 (resolvedFiles, resolvedModules, _) <- 1030 loop (map DotCabalModule (S.toList modulesRemaining)) doneModules 1031 return 1032 ( nubOrd $ foundFiles <> map DotCabalFilePath thDepFiles <> resolvedFiles 1033 , M.union 1034 (M.fromList foundModules) 1035 resolvedModules 1036 , missingModules) 1037 warnUnlisted foundModules = do 1038 let unlistedModules = 1039 foundModules `M.difference` 1040 M.fromList (mapMaybe (fmap (, ()) . dotCabalModule) names0) 1041 return $ 1042 if M.null unlistedModules 1043 then [] 1044 else [ UnlistedModulesWarning 1045 component 1046 (map fst (M.toList unlistedModules))] 1047 warnMissing _missingModules = do 1048 return [] 1049 -- TODO: bring this back - see 1050 -- https://github.com/commercialhaskell/stack/issues/2649 1051 {- 1052 cabalfp <- asks ctxFile 1053 return $ 1054 if null missingModules 1055 then [] 1056 else [ MissingModulesWarning 1057 cabalfp 1058 component 1059 missingModules] 1060 -} 1061 -- TODO: In usages of toResolvedModule / toMissingModule, some sort 1062 -- of map + partition would probably be better. 1063 toResolvedModule 1064 :: (DotCabalDescriptor, Maybe DotCabalPath) 1065 -> Maybe (ModuleName, Path Abs File) 1066 toResolvedModule (DotCabalModule mn, Just (DotCabalModulePath fp)) = 1067 Just (mn, fp) 1068 toResolvedModule _ = 1069 Nothing 1070 toMissingModule 1071 :: (DotCabalDescriptor, Maybe DotCabalPath) 1072 -> Maybe ModuleName 1073 toMissingModule (DotCabalModule mn, Nothing) = 1074 Just mn 1075 toMissingModule _ = 1076 Nothing 1077 1078-- | Get the dependencies of a Haskell module file. 1079getDependencies 1080 :: NamedComponent -> [Path Abs Dir] -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File]) 1081getDependencies component dirs dotCabalPath = 1082 case dotCabalPath of 1083 DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile 1084 DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile 1085 DotCabalFilePath{} -> return (S.empty, []) 1086 DotCabalCFilePath{} -> return (S.empty, []) 1087 where 1088 readResolvedHi resolvedFile = do 1089 dumpHIDir <- componentOutputDir component <$> asks ctxDistDir 1090 dir <- asks (parent . ctxFile) 1091 let sourceDir = fromMaybe dir $ find (`isProperPrefixOf` resolvedFile) dirs 1092 stripSourceDir d = stripProperPrefix d resolvedFile 1093 case stripSourceDir sourceDir of 1094 Nothing -> return (S.empty, []) 1095 Just fileRel -> do 1096 let hiPath = 1097 FilePath.replaceExtension 1098 (toFilePath (dumpHIDir </> fileRel)) 1099 ".hi" 1100 dumpHIExists <- liftIO $ D.doesFileExist hiPath 1101 if dumpHIExists 1102 then parseHI hiPath 1103 else return (S.empty, []) 1104 1105-- | Parse a .hi file into a set of modules and files. 1106parseHI 1107 :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File]) 1108parseHI hiPath = do 1109 dir <- asks (parent . ctxFile) 1110 result <- liftIO $ Iface.fromFile hiPath `catchAnyDeep` \e -> pure (Left (show e)) 1111 case result of 1112 Left msg -> do 1113 prettyStackDevL 1114 [ flow "Failed to decode module interface:" 1115 , style File $ fromString hiPath 1116 , flow "Decoding failure:" 1117 , style Error $ fromString msg 1118 ] 1119 pure (S.empty, []) 1120 Right iface -> do 1121 let moduleNames = fmap (fromString . T.unpack . decodeUtf8Lenient . fst) . 1122 Iface.unList . Iface.dmods . Iface.deps 1123 resolveFileDependency file = do 1124 resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile 1125 when (isNothing resolved) $ 1126 prettyWarnL 1127 [ flow "Dependent file listed in:" 1128 , style File $ fromString hiPath 1129 , flow "does not exist:" 1130 , style File $ fromString file 1131 ] 1132 pure resolved 1133 resolveUsages = traverse (resolveFileDependency . Iface.unUsage) . Iface.unList . Iface.usage 1134 resolvedUsages <- catMaybes <$> resolveUsages iface 1135 pure (S.fromList $ moduleNames iface, resolvedUsages) 1136 1137-- | Try to resolve the list of base names in the given directory by 1138-- looking for unique instances of base names applied with the given 1139-- extensions. 1140resolveFiles 1141 :: [Path Abs Dir] -- ^ Directories to look in. 1142 -> [DotCabalDescriptor] -- ^ Base names. 1143 -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)] 1144resolveFiles dirs names = 1145 forM names (\name -> liftM (name, ) (findCandidate dirs name)) 1146 1147data CabalFileNameParseFail 1148 = CabalFileNameParseFail FilePath 1149 | CabalFileNameInvalidPackageName FilePath 1150 deriving (Typeable) 1151 1152instance Exception CabalFileNameParseFail 1153instance Show CabalFileNameParseFail where 1154 show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp 1155 show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp 1156 1157-- | Parse a package name from a file path. 1158parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName 1159parsePackageNameFromFilePath fp = do 1160 base <- clean $ toFilePath $ filename fp 1161 case parsePackageName base of 1162 Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp 1163 Just x -> return x 1164 where clean = liftM reverse . strip . reverse 1165 strip ('l':'a':'b':'a':'c':'.':xs) = return xs 1166 strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) 1167 1168-- | Find a candidate for the given module-or-filename from the list 1169-- of directories and given extensions. 1170findCandidate 1171 :: [Path Abs Dir] 1172 -> DotCabalDescriptor 1173 -> RIO Ctx (Maybe DotCabalPath) 1174findCandidate dirs name = do 1175 pkg <- asks ctxFile >>= parsePackageNameFromFilePath 1176 customPreprocessorExts <- view $ configL . to configCustomPreprocessorExts 1177 let haskellPreprocessorExts = haskellDefaultPreprocessorExts ++ customPreprocessorExts 1178 candidates <- liftIO $ makeNameCandidates haskellPreprocessorExts 1179 case candidates of 1180 [candidate] -> return (Just (cons candidate)) 1181 [] -> do 1182 case name of 1183 DotCabalModule mn 1184 | D.display mn /= paths_pkg pkg -> logPossibilities dirs mn 1185 _ -> return () 1186 return Nothing 1187 (candidate:rest) -> do 1188 warnMultiple name candidate rest 1189 return (Just (cons candidate)) 1190 where 1191 cons = 1192 case name of 1193 DotCabalModule{} -> DotCabalModulePath 1194 DotCabalMain{} -> DotCabalMainPath 1195 DotCabalFile{} -> DotCabalFilePath 1196 DotCabalCFile{} -> DotCabalCFilePath 1197 paths_pkg pkg = "Paths_" ++ packageNameString pkg 1198 makeNameCandidates haskellPreprocessorExts = 1199 liftM (nubOrd . concat) (mapM (makeDirCandidates haskellPreprocessorExts) dirs) 1200 makeDirCandidates :: [Text] 1201 -> Path Abs Dir 1202 -> IO [Path Abs File] 1203 makeDirCandidates haskellPreprocessorExts dir = 1204 case name of 1205 DotCabalMain fp -> resolveCandidate dir fp 1206 DotCabalFile fp -> resolveCandidate dir fp 1207 DotCabalCFile fp -> resolveCandidate dir fp 1208 DotCabalModule mn -> do 1209 let perExt ext = 1210 resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ T.unpack ext) 1211 withHaskellExts <- mapM perExt haskellFileExts 1212 withPPExts <- mapM perExt haskellPreprocessorExts 1213 pure $ 1214 case (concat withHaskellExts, concat withPPExts) of 1215 -- If we have exactly 1 Haskell extension and exactly 1216 -- 1 preprocessor extension, assume the former file is 1217 -- generated from the latter 1218 -- 1219 -- See https://github.com/commercialhaskell/stack/issues/4076 1220 ([_], [y]) -> [y] 1221 1222 -- Otherwise, return everything 1223 (xs, ys) -> xs ++ ys 1224 resolveCandidate dir = fmap maybeToList . resolveDirFile dir 1225 1226-- | Resolve file as a child of a specified directory, symlinks 1227-- don't get followed. 1228resolveDirFile 1229 :: (MonadIO m, MonadThrow m) 1230 => Path Abs Dir -> FilePath.FilePath -> m (Maybe (Path Abs File)) 1231resolveDirFile x y = do 1232 -- The standard canonicalizePath does not work for this case 1233 p <- parseCollapsedAbsFile (toFilePath x FilePath.</> y) 1234 exists <- doesFileExist p 1235 return $ if exists then Just p else Nothing 1236 1237-- | Warn the user that multiple candidates are available for an 1238-- entry, but that we picked one anyway and continued. 1239warnMultiple 1240 :: DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx () 1241warnMultiple name candidate rest = 1242 -- TODO: figure out how to style 'name' and the dispOne stuff 1243 prettyWarnL 1244 [ flow "There were multiple candidates for the Cabal entry" 1245 , fromString . showName $ name 1246 , line <> bulletedList (map dispOne (candidate:rest)) 1247 , line <> flow "picking:" 1248 , dispOne candidate 1249 ] 1250 where showName (DotCabalModule name') = D.display name' 1251 showName (DotCabalMain fp) = fp 1252 showName (DotCabalFile fp) = fp 1253 showName (DotCabalCFile fp) = fp 1254 dispOne = fromString . toFilePath 1255 -- TODO: figure out why dispOne can't be just `display` 1256 -- (remove the .hlint.yaml exception if it can be) 1257 1258-- | Log that we couldn't find a candidate, but there are 1259-- possibilities for custom preprocessor extensions. 1260-- 1261-- For example: .erb for a Ruby file might exist in one of the 1262-- directories. 1263logPossibilities 1264 :: HasTerm env 1265 => [Path Abs Dir] -> ModuleName -> RIO env () 1266logPossibilities dirs mn = do 1267 possibilities <- liftM concat (makePossibilities mn) 1268 unless (null possibilities) $ prettyWarnL 1269 [ flow "Unable to find a known candidate for the Cabal entry" 1270 , (style PP.Module . fromString $ D.display mn) <> "," 1271 , flow "but did find:" 1272 , line <> bulletedList (map pretty possibilities) 1273 , flow "If you are using a custom preprocessor for this module" 1274 , flow "with its own file extension, consider adding the extension" 1275 , flow "to the 'custom-preprocessor-extensions' field in stack.yaml." 1276 ] 1277 where 1278 makePossibilities name = 1279 mapM 1280 (\dir -> 1281 do (_,files) <- listDir dir 1282 return 1283 (map 1284 filename 1285 (filter 1286 (isPrefixOf (D.display name) . 1287 toFilePath . filename) 1288 files))) 1289 dirs 1290 1291-- | Path for the package's build log. 1292buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m) 1293 => Package -> Maybe String -> m (Path Abs File) 1294buildLogPath package' msuffix = do 1295 env <- ask 1296 let stack = getProjectWorkDir env 1297 fp <- parseRelFile $ concat $ 1298 packageIdentifierString (packageIdentifier package') : 1299 maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"] 1300 return $ stack </> relDirLogs </> fp 1301 1302-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn 1303resolveOrWarn :: Text 1304 -> (Path Abs Dir -> String -> RIO Ctx (Maybe a)) 1305 -> FilePath.FilePath 1306 -> RIO Ctx (Maybe a) 1307resolveOrWarn subject resolver path = 1308 do cwd <- liftIO getCurrentDir 1309 file <- asks ctxFile 1310 dir <- asks (parent . ctxFile) 1311 result <- resolver dir path 1312 when (isNothing result) $ warnMissingFile subject cwd path file 1313 return result 1314 1315warnMissingFile :: Text -> Path Abs Dir -> FilePath -> Path Abs File -> RIO Ctx () 1316warnMissingFile subject cwd path fromFile = 1317 prettyWarnL 1318 [ fromString . T.unpack $ subject -- TODO: needs style? 1319 , flow "listed in" 1320 , maybe (pretty fromFile) pretty (stripProperPrefix cwd fromFile) 1321 , flow "file does not exist:" 1322 , style Dir . fromString $ path 1323 ] 1324 1325-- | Resolve the file, if it can't be resolved, warn for the user 1326-- (purely to be helpful). 1327resolveFileOrWarn :: FilePath.FilePath 1328 -> RIO Ctx (Maybe (Path Abs File)) 1329resolveFileOrWarn = resolveOrWarn "File" f 1330 where f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile 1331 1332-- | Resolve the directory, if it can't be resolved, warn for the user 1333-- (purely to be helpful). 1334resolveDirOrWarn :: FilePath.FilePath 1335 -> RIO Ctx (Maybe (Path Abs Dir)) 1336resolveDirOrWarn = resolveOrWarn "Directory" f 1337 where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir 1338 1339 {- FIXME 1340-- | Create a 'ProjectPackage' from a directory containing a package. 1341mkProjectPackage 1342 :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 1343 => PrintWarnings 1344 -> ResolvedPath Dir 1345 -> RIO env ProjectPackage 1346mkProjectPackage printWarnings dir = do 1347 (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir) 1348 return ProjectPackage 1349 { ppCabalFP = cabalfp 1350 , ppGPD' = gpd printWarnings 1351 , ppResolvedDir = dir 1352 , ppName = name 1353 } 1354 1355-- | Create a 'DepPackage' from a 'PackageLocation' 1356mkDepPackage 1357 :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 1358 => PackageLocation 1359 -> RIO env DepPackage 1360mkDepPackage pl = do 1361 (name, gpdio) <- 1362 case pl of 1363 PLMutable dir -> do 1364 (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir) 1365 pure (name, gpdio NoPrintWarnings) 1366 PLImmutable pli -> do 1367 PackageIdentifier name _ <- getPackageLocationIdent pli 1368 run <- askRunInIO 1369 pure (name, run $ loadCabalFileImmutable pli) 1370 return DepPackage 1371 { dpGPD' = gpdio 1372 , dpLocation = pl 1373 , dpName = name 1374 } 1375 1376 -} 1377 1378-- | Force a package to be treated as a custom build type, see 1379-- <https://github.com/commercialhaskell/stack/issues/4488> 1380applyForceCustomBuild 1381 :: Version -- ^ global Cabal version 1382 -> Package 1383 -> Package 1384applyForceCustomBuild cabalVersion package 1385 | forceCustomBuild = 1386 package 1387 { packageBuildType = Custom 1388 , packageDeps = M.insertWith (<>) "Cabal" (DepValue cabalVersionRange AsLibrary) 1389 $ packageDeps package 1390 , packageSetupDeps = Just $ M.fromList 1391 [ ("Cabal", cabalVersionRange) 1392 , ("base", anyVersion) 1393 ] 1394 } 1395 | otherwise = package 1396 where 1397 cabalVersionRange = packageCabalSpec package 1398 forceCustomBuild = 1399 packageBuildType package == Simple && 1400 not (cabalVersion `withinRange` cabalVersionRange) 1401