module Stack.Build
(build
,withLoadPackage
,mkBaseConfigOpts
,queryBuildInfo
,splitObjsWarning
,CabalVersionException(..))
where
import Stack.Prelude
import Data.Aeson (Value (Object, Array), (.=), object)
import qualified Data.HashMap.Strict as HM
import Data.List ((\\))
import Data.List.Extra (groupSort)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as TIO
import Data.Text.Read (decimal)
import qualified Data.Vector as V
import qualified Data.Yaml as Yaml
import Stack.Build.ConstructPlan
import Stack.Build.Execute
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Build.Target
import Stack.Fetch as Fetch
import Stack.Package
import Stack.PackageLocation (parseSingleCabalFileIndex)
import Stack.Types.Build
import Stack.Types.BuildPlan
import Stack.Types.Config
import Stack.Types.FlagName
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
#ifdef WINDOWS
import Stack.Types.Compiler
#endif
import System.FileLock (FileLock, unlockFile)
#ifdef WINDOWS
import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
#endif
build :: HasEnvConfig env
=> (Set (Path Abs File) -> IO ())
-> Maybe FileLock
-> BuildOptsCLI
-> RIO env ()
build setLocalFiles mbuildLk boptsCli = fixCodePage $ do
bopts <- view buildOptsL
let profiling = boptsLibProfile bopts || boptsExeProfile bopts
let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts)
menv <- getMinimalEnvOverride
(targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli
stackYaml <- view stackYamlL
liftIO $ setLocalFiles
$ Set.insert stackYaml
$ Set.unions
[lpFiles lp | PSFiles lp _ <- Map.elems sourceMap]
(installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <-
getInstalled menv
GetInstalledOpts
{ getInstalledProfiling = profiling
, getInstalledHaddock = shouldHaddockDeps bopts
, getInstalledSymbols = symbols }
sourceMap
baseConfigOpts <- mkBaseConfigOpts boptsCli
plan <- withLoadPackage $ \loadPackage ->
constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli)
allowLocals <- view $ configL.to configAllowLocals
unless allowLocals $ case justLocals plan of
[] -> return ()
localsIdents -> throwM $ LocalPackagesPresent localsIdents
case (mbuildLk, allLocal plan) of
(Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early."
liftIO $ unlockFile lk
_ -> return ()
checkCabalVersion
warnAboutSplitObjs bopts
warnIfExecutablesWithSameNameCouldBeOverwritten locals plan
when (boptsPreFetch bopts) $
preFetch plan
if boptsCLIDryrun boptsCli
then printPlan plan
else executePlan menv boptsCli baseConfigOpts locals
globalDumpPkgs
snapshotDumpPkgs
localDumpPkgs
installedMap
targets
plan
allLocal :: Plan -> Bool
allLocal =
all (== Local) .
map taskLocation .
Map.elems .
planTasks
justLocals :: Plan -> [PackageIdentifier]
justLocals =
map taskProvides .
filter ((== Local) . taskLocation) .
Map.elems .
planTasks
checkCabalVersion :: HasEnvConfig env => RIO env ()
checkCabalVersion = do
allowNewer <- view $ configL.to configAllowNewer
cabalVer <- view cabalVersionL
when (allowNewer && cabalVer < $(mkVersion "1.22")) $ throwM $
CabalVersionException $
"Error: --allow-newer requires at least Cabal version 1.22, but version " ++
versionString cabalVer ++
" was found."
newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String }
deriving (Typeable)
instance Show CabalVersionException where show = unCabalVersionException
instance Exception CabalVersionException
warnIfExecutablesWithSameNameCouldBeOverwritten
:: MonadLogger m => [LocalPackage] -> Plan -> m ()
warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do
logDebug "Checking if we are going to build multiple executables with the same name"
forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do
let exe_s
| length toBuild > 1 = "several executables with the same name:"
| otherwise = "executable"
exesText pkgs =
T.intercalate
", "
["'" <> packageNameText p <> ":" <> exe <> "'" | p <- pkgs]
(logWarn . T.unlines . concat)
[ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ]
, [ "Only one of them will be available via 'stack exec' or locally installed."
| length toBuild > 1
]
, [ "Other executables with the same name might be overwritten: " <>
exesText otherLocals <> "."
| not (null otherLocals)
]
]
where
warnings :: Map Text ([PackageName],[PackageName])
warnings =
Map.mapMaybe
(\(pkgsToBuild,localPkgs) ->
case (pkgsToBuild,NE.toList localPkgs \\ NE.toList pkgsToBuild) of
(_ :| [],[]) ->
Nothing
(_,otherLocals) ->
Just (NE.toList pkgsToBuild,otherLocals))
(Map.intersectionWith (,) exesToBuild localExes)
exesToBuild :: Map Text (NonEmpty PackageName)
exesToBuild =
collect
[ (exe,pkgName)
| (pkgName,task) <- Map.toList (planTasks plan)
, TTFiles lp _ <- [taskType task]
, exe <- (Set.toList . exeComponents . lpComponents) lp
]
localExes :: Map Text (NonEmpty PackageName)
localExes =
collect
[ (exe,packageName pkg)
| pkg <- map lpPackage locals
, exe <- Set.toList (packageExes pkg)
]
collect :: Ord k => [(k,v)] -> Map k (NonEmpty v)
collect = Map.map NE.fromList . Map.fromDistinctAscList . groupSort
warnAboutSplitObjs :: MonadLogger m => BuildOpts -> m ()
warnAboutSplitObjs bopts | boptsSplitObjs bopts = do
logWarn $ "Building with --split-objs is enabled. " <> T.pack splitObjsWarning
warnAboutSplitObjs _ = return ()
splitObjsWarning :: String
splitObjsWarning = unwords
[ "Note that this feature is EXPERIMENTAL, and its behavior may be changed and improved."
, "You will need to clean your workdirs before use. If you want to compile all dependencies"
, "with split-objs, you will need to delete the snapshot (and all snapshots that could"
, "reference that snapshot)."
]
mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> BuildOptsCLI -> m BaseConfigOpts
mkBaseConfigOpts boptsCli = do
bopts <- view buildOptsL
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
snapInstallRoot <- installationRootDeps
localInstallRoot <- installationRootLocal
packageExtraDBs <- packageDatabaseExtra
return BaseConfigOpts
{ bcoSnapDB = snapDBPath
, bcoLocalDB = localDBPath
, bcoSnapInstallRoot = snapInstallRoot
, bcoLocalInstallRoot = localInstallRoot
, bcoBuildOpts = bopts
, bcoBuildOptsCLI = boptsCli
, bcoExtraDBs = packageExtraDBs
}
withLoadPackage :: HasEnvConfig env
=> ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> RIO env a)
-> RIO env a
withLoadPackage inner = do
econfig <- view envConfigL
root <- view projectRootL
run <- askRunInIO
withCabalLoader $ \loadFromIndex ->
inner $ \loc flags ghcOptions -> run $
resolvePackage
(depPackageConfig econfig flags ghcOptions)
<$> parseSingleCabalFileIndex loadFromIndex root loc
where
depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig
depPackageConfig econfig flags ghcOptions = PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = flags
, packageConfigGhcOptions = ghcOptions
, packageConfigCompilerVersion = view actualCompilerVersionL econfig
, packageConfigPlatform = view platformL econfig
}
fixCodePage :: HasEnvConfig env => RIO env a -> RIO env a
#ifdef WINDOWS
fixCodePage inner = do
mcp <- view $ configL.to configModifyCodePage
ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion
if mcp && ghcVersion < $(mkVersion "7.10.3")
then fixCodePage'
else inner
where
fixCodePage' = do
origCPI <- liftIO getConsoleCP
origCPO <- liftIO getConsoleOutputCP
let setInput = origCPI /= expected
setOutput = origCPO /= expected
fixInput
| setInput = bracket_
(liftIO $ do
setConsoleCP expected)
(liftIO $ setConsoleCP origCPI)
| otherwise = id
fixOutput
| setOutput = bracket_
(liftIO $ do
setConsoleOutputCP expected)
(liftIO $ setConsoleOutputCP origCPO)
| otherwise = id
case (setInput, setOutput) of
(False, False) -> return ()
(True, True) -> warn ""
(True, False) -> warn " input"
(False, True) -> warn " output"
fixInput $ fixOutput inner
expected = 65001
warn typ = logInfo $ T.concat
[ "Setting"
, typ
, " codepage to UTF-8 (65001) to ensure correct output from GHC"
]
#else
fixCodePage = id
#endif
queryBuildInfo :: HasEnvConfig env
=> [Text]
-> RIO env ()
queryBuildInfo selectors0 =
rawBuildInfo
>>= select id selectors0
>>= liftIO . TIO.putStrLn . decodeUtf8 . Yaml.encode
where
select _ [] value = return value
select front (sel:sels) value =
case value of
Object o ->
case HM.lookup sel o of
Nothing -> err "Selector not found"
Just value' -> cont value'
Array v ->
case decimal sel of
Right (i, "")
| i >= 0 && i < V.length v -> cont $ v V.! i
| otherwise -> err "Index out of range"
_ -> err "Encountered array and needed numeric selector"
_ -> err $ "Cannot apply selector to " ++ show value
where
cont = select (front . (sel:)) sels
err msg = throwString $ msg ++ ": " ++ show (front [sel])
rawBuildInfo :: HasEnvConfig env => RIO env Value
rawBuildInfo = do
(locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI
return $ object
[ "locals" .= Object (HM.fromList $ map localToPair locals)
]
where
localToPair lp =
(T.pack $ packageNameString $ packageName p, value)
where
p = lpPackage lp
value = object
[ "version" .= packageVersion p
, "path" .= toFilePath (lpDir lp)
]