1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7 8-- | Build the project. 9 10module Stack.Build 11 (build 12 ,buildLocalTargets 13 ,loadPackage 14 ,mkBaseConfigOpts 15 ,queryBuildInfo 16 ,splitObjsWarning 17 ,CabalVersionException(..)) 18 where 19 20import Stack.Prelude hiding (loadPackage) 21import Data.Aeson (Value (Object, Array), (.=), object) 22import qualified Data.HashMap.Strict as HM 23import Data.List ((\\), isPrefixOf) 24import Data.List.Extra (groupSort) 25import qualified Data.List.NonEmpty as NE 26import qualified Data.Map as Map 27import qualified Data.Set as Set 28import qualified Data.Text as T 29import Data.Text.Encoding (decodeUtf8) 30import qualified Data.Text.IO as TIO 31import Data.Text.Read (decimal) 32import qualified Data.Vector as V 33import qualified Data.Yaml as Yaml 34import qualified Distribution.PackageDescription as C 35import Distribution.Types.Dependency (depLibraries) 36import Distribution.Version (mkVersion) 37import Path (parent) 38import Stack.Build.ConstructPlan 39import Stack.Build.Execute 40import Stack.Build.Installed 41import Stack.Build.Source 42import Stack.Package 43import Stack.Setup (withNewLocalBuildTargets) 44import Stack.Types.Build 45import Stack.Types.Config 46import Stack.Types.NamedComponent 47import Stack.Types.Package 48import Stack.Types.SourceMap 49 50import Stack.Types.Compiler (compilerVersionText, getGhcVersion) 51import System.Terminal (fixCodePage) 52 53-- | Build. 54-- 55-- If a buildLock is passed there is an important contract here. That lock must 56-- protect the snapshot, and it must be safe to unlock it if there are no further 57-- modifications to the snapshot to be performed by this build. 58build :: HasEnvConfig env 59 => Maybe (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files 60 -> RIO env () 61build msetLocalFiles = do 62 mcp <- view $ configL.to configModifyCodePage 63 ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion 64 fixCodePage mcp ghcVersion $ do 65 bopts <- view buildOptsL 66 sourceMap <- view $ envConfigL.to envConfigSourceMap 67 locals <- projectLocalPackages 68 depsLocals <- localDependencies 69 let allLocals = locals <> depsLocals 70 71 checkSubLibraryDependencies (Map.elems $ smProject sourceMap) 72 73 boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI 74 -- Set local files, necessary for file watching 75 stackYaml <- view stackYamlL 76 for_ msetLocalFiles $ \setLocalFiles -> do 77 files <- 78 if boptsCLIWatchAll boptsCli 79 then sequence [lpFiles lp | lp <- allLocals] 80 else forM allLocals $ \lp -> do 81 let pn = packageName (lpPackage lp) 82 case Map.lookup pn (smtTargets $ smTargets sourceMap) of 83 Nothing -> 84 pure Set.empty 85 Just (TargetAll _) -> 86 lpFiles lp 87 Just (TargetComps components) -> 88 lpFilesForComponents components lp 89 liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions files 90 91 checkComponentsBuildable allLocals 92 93 installMap <- toInstallMap sourceMap 94 (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- 95 getInstalled installMap 96 97 baseConfigOpts <- mkBaseConfigOpts boptsCli 98 plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) 99 100 allowLocals <- view $ configL.to configAllowLocals 101 unless allowLocals $ case justLocals plan of 102 [] -> return () 103 localsIdents -> throwM $ LocalPackagesPresent localsIdents 104 105 checkCabalVersion 106 warnAboutSplitObjs bopts 107 warnIfExecutablesWithSameNameCouldBeOverwritten locals plan 108 109 when (boptsPreFetch bopts) $ 110 preFetch plan 111 112 if boptsCLIDryrun boptsCli 113 then printPlan plan 114 else executePlan boptsCli baseConfigOpts locals 115 globalDumpPkgs 116 snapshotDumpPkgs 117 localDumpPkgs 118 installedMap 119 (smtTargets $ smTargets sourceMap) 120 plan 121 122buildLocalTargets :: HasEnvConfig env => NonEmpty Text -> RIO env (Either SomeException ()) 123buildLocalTargets targets = 124 tryAny $ withNewLocalBuildTargets (NE.toList targets) $ build Nothing 125 126justLocals :: Plan -> [PackageIdentifier] 127justLocals = 128 map taskProvides . 129 filter ((== Local) . taskLocation) . 130 Map.elems . 131 planTasks 132 133checkCabalVersion :: HasEnvConfig env => RIO env () 134checkCabalVersion = do 135 allowNewer <- view $ configL.to configAllowNewer 136 cabalVer <- view cabalVersionL 137 -- https://github.com/haskell/cabal/issues/2023 138 when (allowNewer && cabalVer < mkVersion [1, 22]) $ throwM $ 139 CabalVersionException $ 140 "Error: --allow-newer requires at least Cabal version 1.22, but version " ++ 141 versionString cabalVer ++ 142 " was found." 143 -- Since --exact-configuration is always passed, some old cabal 144 -- versions can no longer be used. See the following link for why 145 -- it's 1.19.2: 146 -- https://github.com/haskell/cabal/blob/580fe6b6bf4e1648b2f66c1cb9da9f1f1378492c/cabal-install/Distribution/Client/Setup.hs#L592 147 when (cabalVer < mkVersion [1, 19, 2]) $ throwM $ 148 CabalVersionException $ 149 "Stack no longer supports Cabal versions older than 1.19.2, but version " ++ 150 versionString cabalVer ++ 151 " was found. To fix this, consider updating the resolver to lts-3.0 or later / nightly-2015-05-05 or later." 152 153newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String } 154 deriving (Typeable) 155 156instance Show CabalVersionException where show = unCabalVersionException 157instance Exception CabalVersionException 158 159-- | See https://github.com/commercialhaskell/stack/issues/1198. 160warnIfExecutablesWithSameNameCouldBeOverwritten 161 :: HasLogFunc env => [LocalPackage] -> Plan -> RIO env () 162warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do 163 logDebug "Checking if we are going to build multiple executables with the same name" 164 forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do 165 let exe_s 166 | length toBuild > 1 = "several executables with the same name:" 167 | otherwise = "executable" 168 exesText pkgs = 169 T.intercalate 170 ", " 171 ["'" <> T.pack (packageNameString p) <> ":" <> exe <> "'" | p <- pkgs] 172 (logWarn . display . T.unlines . concat) 173 [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ] 174 , [ "Only one of them will be available via 'stack exec' or locally installed." 175 | length toBuild > 1 176 ] 177 , [ "Other executables with the same name might be overwritten: " <> 178 exesText otherLocals <> "." 179 | not (null otherLocals) 180 ] 181 ] 182 where 183 -- Cases of several local packages having executables with the same name. 184 -- The Map entries have the following form: 185 -- 186 -- executable name: ( package names for executables that are being built 187 -- , package names for other local packages that have an 188 -- executable with the same name 189 -- ) 190 warnings :: Map Text ([PackageName],[PackageName]) 191 warnings = 192 Map.mapMaybe 193 (\(pkgsToBuild,localPkgs) -> 194 case (pkgsToBuild,NE.toList localPkgs \\ NE.toList pkgsToBuild) of 195 (_ :| [],[]) -> 196 -- We want to build the executable of single local package 197 -- and there are no other local packages with an executable of 198 -- the same name. Nothing to warn about, ignore. 199 Nothing 200 (_,otherLocals) -> 201 -- We could be here for two reasons (or their combination): 202 -- 1) We are building two or more executables with the same 203 -- name that will end up overwriting each other. 204 -- 2) In addition to the executable(s) that we want to build 205 -- there are other local packages with an executable of the 206 -- same name that might get overwritten. 207 -- Both cases warrant a warning. 208 Just (NE.toList pkgsToBuild,otherLocals)) 209 (Map.intersectionWith (,) exesToBuild localExes) 210 exesToBuild :: Map Text (NonEmpty PackageName) 211 exesToBuild = 212 collect 213 [ (exe,pkgName') 214 | (pkgName',task) <- Map.toList (planTasks plan) 215 , TTLocalMutable lp <- [taskType task] 216 , exe <- (Set.toList . exeComponents . lpComponents) lp 217 ] 218 localExes :: Map Text (NonEmpty PackageName) 219 localExes = 220 collect 221 [ (exe,packageName pkg) 222 | pkg <- map lpPackage locals 223 , exe <- Set.toList (packageExes pkg) 224 ] 225 collect :: Ord k => [(k,v)] -> Map k (NonEmpty v) 226 collect = Map.map NE.fromList . Map.fromDistinctAscList . groupSort 227 228warnAboutSplitObjs :: HasLogFunc env => BuildOpts -> RIO env () 229warnAboutSplitObjs bopts | boptsSplitObjs bopts = do 230 logWarn $ "Building with --split-objs is enabled. " <> fromString splitObjsWarning 231warnAboutSplitObjs _ = return () 232 233splitObjsWarning :: String 234splitObjsWarning = unwords 235 [ "Note that this feature is EXPERIMENTAL, and its behavior may be changed and improved." 236 , "You will need to clean your workdirs before use. If you want to compile all dependencies" 237 , "with split-objs, you will need to delete the snapshot (and all snapshots that could" 238 , "reference that snapshot)." 239 ] 240 241-- | Get the @BaseConfigOpts@ necessary for constructing configure options 242mkBaseConfigOpts :: (HasEnvConfig env) 243 => BuildOptsCLI -> RIO env BaseConfigOpts 244mkBaseConfigOpts boptsCli = do 245 bopts <- view buildOptsL 246 snapDBPath <- packageDatabaseDeps 247 localDBPath <- packageDatabaseLocal 248 snapInstallRoot <- installationRootDeps 249 localInstallRoot <- installationRootLocal 250 packageExtraDBs <- packageDatabaseExtra 251 return BaseConfigOpts 252 { bcoSnapDB = snapDBPath 253 , bcoLocalDB = localDBPath 254 , bcoSnapInstallRoot = snapInstallRoot 255 , bcoLocalInstallRoot = localInstallRoot 256 , bcoBuildOpts = bopts 257 , bcoBuildOptsCLI = boptsCli 258 , bcoExtraDBs = packageExtraDBs 259 } 260 261-- | Provide a function for loading package information from the package index 262loadPackage 263 :: (HasBuildConfig env, HasSourceMap env) 264 => PackageLocationImmutable 265 -> Map FlagName Bool 266 -> [Text] -- ^ GHC options 267 -> [Text] -- ^ Cabal configure options 268 -> RIO env Package 269loadPackage loc flags ghcOptions cabalConfigOpts = do 270 compiler <- view actualCompilerVersionL 271 platform <- view platformL 272 let pkgConfig = PackageConfig 273 { packageConfigEnableTests = False 274 , packageConfigEnableBenchmarks = False 275 , packageConfigFlags = flags 276 , packageConfigGhcOptions = ghcOptions 277 , packageConfigCabalConfigOpts = cabalConfigOpts 278 , packageConfigCompilerVersion = compiler 279 , packageConfigPlatform = platform 280 } 281 resolvePackage pkgConfig <$> loadCabalFileImmutable loc 282 283-- | Query information about the build and print the result to stdout in YAML format. 284queryBuildInfo :: HasEnvConfig env 285 => [Text] -- ^ selectors 286 -> RIO env () 287queryBuildInfo selectors0 = 288 rawBuildInfo 289 >>= select id selectors0 290 >>= liftIO . TIO.putStrLn . addGlobalHintsComment . decodeUtf8 . Yaml.encode 291 where 292 select _ [] value = return value 293 select front (sel:sels) value = 294 case value of 295 Object o -> 296 case HM.lookup sel o of 297 Nothing -> err "Selector not found" 298 Just value' -> cont value' 299 Array v -> 300 case decimal sel of 301 Right (i, "") 302 | i >= 0 && i < V.length v -> cont $ v V.! i 303 | otherwise -> err "Index out of range" 304 _ -> err "Encountered array and needed numeric selector" 305 _ -> err $ "Cannot apply selector to " ++ show value 306 where 307 cont = select (front . (sel:)) sels 308 err msg = throwString $ msg ++ ": " ++ show (front [sel]) 309 -- Include comments to indicate that this portion of the "stack 310 -- query" API is not necessarily stable. 311 addGlobalHintsComment 312 | null selectors0 = T.replace globalHintsLine ("\n" <> globalHintsComment <> globalHintsLine) 313 -- Append comment instead of pre-pending. The reasoning here is 314 -- that something *could* expect that the result of 'stack query 315 -- global-hints ghc-boot' is just a string literal. Seems easier 316 -- for to expect the first line of the output to be the literal. 317 | ["global-hints"] `isPrefixOf` selectors0 = (<> ("\n" <> globalHintsComment)) 318 | otherwise = id 319 globalHintsLine = "\nglobal-hints:\n" 320 globalHintsComment = T.concat 321 [ "# Note: global-hints is experimental and may be renamed / removed in the future.\n" 322 , "# See https://github.com/commercialhaskell/stack/issues/3796" 323 ] 324-- | Get the raw build information object 325rawBuildInfo :: HasEnvConfig env => RIO env Value 326rawBuildInfo = do 327 locals <- projectLocalPackages 328 wantedCompiler <- view $ wantedCompilerVersionL.to (utf8BuilderToText . display) 329 actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText 330 return $ object 331 [ "locals" .= Object (HM.fromList $ map localToPair locals) 332 , "compiler" .= object 333 [ "wanted" .= wantedCompiler 334 , "actual" .= actualCompiler 335 ] 336 ] 337 where 338 localToPair lp = 339 (T.pack $ packageNameString $ packageName p, value) 340 where 341 p = lpPackage lp 342 value = object 343 [ "version" .= CabalString (packageVersion p) 344 , "path" .= toFilePath (parent $ lpCabalFile lp) 345 ] 346 347checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m () 348checkComponentsBuildable lps = 349 unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable 350 where 351 unbuildable = 352 [ (packageName (lpPackage lp), c) 353 | lp <- lps 354 , c <- Set.toList (lpUnbuildable lp) 355 ] 356 357-- | Find if sublibrary dependency exist in each project 358checkSubLibraryDependencies :: HasLogFunc env => [ProjectPackage] -> RIO env () 359checkSubLibraryDependencies proj = do 360 forM_ proj $ \p -> do 361 C.GenericPackageDescription _ _ lib subLibs foreignLibs exes tests benches <- liftIO $ cpGPD . ppCommon $ p 362 363 let dependencies = concatMap getDeps subLibs <> 364 concatMap getDeps foreignLibs <> 365 concatMap getDeps exes <> 366 concatMap getDeps tests <> 367 concatMap getDeps benches <> 368 maybe [] C.condTreeConstraints lib 369 libraries = concatMap (toList . depLibraries) dependencies 370 371 when (subLibDepExist libraries) 372 (logWarn "SubLibrary dependency is not supported, this will almost certainly fail") 373 where 374 getDeps (_, C.CondNode _ dep _) = dep 375 subLibDepExist lib = 376 any (\x -> 377 case x of 378 C.LSubLibName _ -> True 379 C.LMainLibName -> False 380 ) lib 381