{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE RecordWildCards #-}

-- | Main stack tool entry point.

module Main (main) where

import BuildInfo

import Stack.Prelude hiding (Display (..))

import Conduit (runConduitRes, sourceLazy, sinkFileCautious)

import Control.Monad.Reader (local)

import Control.Monad.Trans.Except (ExceptT)

import Control.Monad.Writer.Lazy (Writer)

import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))

import Data.Attoparsec.Interpreter (getInterpreterArgs)

import Data.List

import qualified Data.Map.Strict as Map

import qualified Data.Set as Set

import qualified Data.Text as T

import Data.Version (showVersion)

import RIO.Process

import Distribution.Version (mkVersion')

import GHC.IO.Encoding (mkTextEncoding, textEncodingName)

import Options.Applicative

import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks)

import Options.Applicative.Builder.Extra

import Options.Applicative.Complicated

import Options.Applicative.Types (ParserHelp(..))

import Pantry (loadSnapshot)

import Path

import Path.IO

import qualified Paths_stack as Meta

import RIO.PrettyPrint

import qualified RIO.PrettyPrint as PP (style)

import Stack.Build

import Stack.Build.Target (NeedTargets(..))

import Stack.Clean (CleanCommand(..), CleanOpts(..), clean)

import Stack.Config

import Stack.ConfigCmd as ConfigCmd

import Stack.Constants

import Stack.Constants.Config

import Stack.Coverage

import qualified Stack.Docker as Docker

import Stack.Dot

import Stack.GhcPkg (findGhcPkgField)

import qualified Stack.Nix as Nix

import Stack.FileWatch

import Stack.Freeze

import Stack.Ghci

import Stack.Hoogle

import Stack.Ls

import qualified Stack.IDE as IDE

import Stack.Init

import Stack.New

import Stack.Options.BuildParser

import Stack.Options.CleanParser

import Stack.Options.DockerParser

import Stack.Options.DotParser

import Stack.Options.ExecParser

import Stack.Options.GhciParser

import Stack.Options.GlobalParser

import Stack.Options.FreezeParser

import Stack.Options.HpcReportParser

import Stack.Options.NewParser

import Stack.Options.NixParser

import Stack.Options.ScriptParser

import Stack.Options.SDistParser

import Stack.Options.Utils

import qualified Stack.Path

import Stack.Runners

import Stack.Script

import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..))

import Stack.Setup (withNewLocalBuildTargets)

import Stack.SetupCmd

import Stack.Types.Version

import Stack.Types.Config

import Stack.Types.NamedComponent

import Stack.Types.SourceMap

import Stack.Unpack

import Stack.Upgrade

import qualified Stack.Upload as Upload

import qualified System.Directory as D

import System.Environment (getProgName, getArgs, withArgs)

import System.FilePath (isValid, pathSeparator, takeDirectory)

import qualified System.FilePath as FP

import System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hGetEncoding, hSetEncoding)

import System.Terminal (hIsTerminalDeviceOrMinTTY)

-- | Change the character encoding of the given Handle to transliterate

-- on unsupported characters instead of throwing an exception

hSetTranslit :: Handle -> IO ()

hSetTranslit h = do

menc <- hGetEncoding h

case fmap textEncodingName menc of

Just name

| '/' `notElem` name -> do

enc' <- mkTextEncoding $ name ++ "//TRANSLIT"

hSetEncoding h enc'

_ -> return ()

main :: IO ()

main = do

-- Line buffer the output by default, particularly for non-terminal runs.

-- See https://github.com/commercialhaskell/stack/pull/360

hSetBuffering stdout LineBuffering

hSetBuffering stdin LineBuffering

hSetBuffering stderr LineBuffering

hSetTranslit stdout

hSetTranslit stderr

args <- getArgs

progName <- getProgName

isTerminal <- hIsTerminalDeviceOrMinTTY stdout

-- On Windows, where applicable, defaultColorWhen has the side effect of

-- enabling ANSI for ANSI-capable native (ConHost) terminals, if not already

-- ANSI-enabled.

execExtraHelp args

Docker.dockerHelpOptName

(dockerOptsParser False)

("Only showing --" ++ Docker.dockerCmdName ++ "* options.")

execExtraHelp args

Nix.nixHelpOptName

(nixOptsParser False)

("Only showing --" ++ Nix.nixCmdName ++ "* options.")

currentDir <- D.getCurrentDirectory

eGlobalRun <- try $ commandLineHandler currentDir progName False

case eGlobalRun of

Left (exitCode :: ExitCode) ->

throwIO exitCode

Right (globalMonoid,run) -> do

global <- globalOptsFromMonoid isTerminal globalMonoid

when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'

case globalReExecVersion global of

Just expectVersion -> do

expectVersion' <- parseVersionThrowing expectVersion

unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))

$ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)

_ -> return ()

withRunnerGlobal global $ run `catch` \e ->

-- This special handler stops "stack: " from being printed before the

-- exception

case fromException e of

Just ec -> exitWith ec

Nothing -> do

logError $ fromString $ displayException e

exitFailure

-- Vertically combine only the error component of the first argument with the

-- error component of the second.

vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp

vcatErrorHelp h1 h2 = h2 { helpError = vcatChunks [helpError h2, helpError h1] }

commandLineHandler

:: FilePath

-> String

-> Bool

-> IO (GlobalOptsMonoid, RIO Runner ())

commandLineHandler currentDir progName isInterpreter = complicatedOptions

(mkVersion' Meta.version)

(Just versionString')

hpackVersion

"stack - The Haskell Tool Stack"

""

"stack's documentation is available at https://docs.haskellstack.org/"

(globalOpts OuterGlobalOpts)

(Just failureCallback)

addCommands

where

failureCallback f args =

case stripPrefix "Invalid argument" (fst (renderFailure f "")) of

Just _ -> if isInterpreter

then parseResultHandler args f

else secondaryCommandHandler args f

>>= interpreterHandler currentDir args

Nothing -> parseResultHandler args f

parseResultHandler args f =

if isInterpreter

then do

let hlp = errorHelp $ stringChunk

(unwords ["Error executing interpreter command:"

, progName

, unwords args])

handleParseResult (overFailure (vcatErrorHelp hlp) (Failure f))

else handleParseResult (Failure f)

addCommands = do

unless isInterpreter (do

addBuildCommand' "build"

"Build the package(s) in this directory/configuration"

buildCmd

(buildOptsParser Build)

addBuildCommand' "install"

"Shortcut for 'build --copy-bins'"

buildCmd

(buildOptsParser Install)

addCommand' "uninstall"

"DEPRECATED: This command performs no actions, and is present for documentation only"

uninstallCmd

(many $ strArgument $ metavar "IGNORED")

addBuildCommand' "test"

"Shortcut for 'build --test'"

buildCmd

(buildOptsParser Test)

addBuildCommand' "bench"

"Shortcut for 'build --bench'"

buildCmd

(buildOptsParser Bench)

addBuildCommand' "haddock"

"Shortcut for 'build --haddock'"

buildCmd

(buildOptsParser Haddock)

addCommand' "new"

(unwords [ "Create a new project from a template."

, "Run `stack templates' to see available templates."

, "Note: you can also specify a local file or a"

, "remote URL as a template."

] )

newCmd

newOptsParser

addCommand' "templates"

(unwords [ "Show how to find templates available for `stack new'."

, "`stack new' can accept a template from a remote repository"

, "(default: github), local file or remote URL."

, "Note: this downloads the help file."

] )

templatesCmd

(pure ())

addCommand' "init"

"Create stack project config from cabal or hpack package specifications"

initCmd

initOptsParser

addCommand' "setup"

"Get the appropriate GHC for your project"

setupCmd

setupParser

addCommand' "path"

"Print out handy path information"

Stack.Path.path

Stack.Path.pathParser

addCommand' "ls"

"List command. (Supports snapshots, dependencies and stack's styles)"

lsCmd

lsParser

addCommand' "unpack"

"Unpack one or more packages locally"

unpackCmd

((,) <$> some (strArgument $ metavar "PACKAGE")

<*> optional (textOption $ long "to" <>

help "Optional path to unpack the package into (will unpack into subdirectory)"))

addCommand' "update"

"Update the package index"

updateCmd

(pure ())

addCommand' "upgrade"

"Upgrade to the latest stack"

upgradeCmd

upgradeOpts

addCommand'

"upload"

"Upload a package to Hackage"

uploadCmd

sdistOptsParser

addCommand'

"sdist"

"Create source distribution tarballs"

sdistCmd

sdistOptsParser

addCommand' "dot"

"Visualize your project's dependency graph using Graphviz dot"

dot

(dotOptsParser False) -- Default for --external is False.

addCommand' "ghc"

"Run ghc"

execCmd

(execOptsParser $ Just ExecGhc)

addCommand' "hoogle"

("Run hoogle, the Haskell API search engine. Use 'stack exec' syntax " ++

"to pass Hoogle arguments, e.g. stack hoogle -- --count=20 or " ++

"stack hoogle -- server --local")

hoogleCmd

((,,,) <$> many (strArgument (metavar "ARG"))

<*> boolFlags

True

"setup"

"If needed: install hoogle, build haddocks and generate a hoogle database"

idm

<*> switch

(long "rebuild" <>

help "Rebuild the hoogle database")

<*> switch

(long "server" <>

help "Start local Hoogle server"))

)

-- These are the only commands allowed in interpreter mode as well

addCommand' "exec"

"Execute a command"

execCmd

(execOptsParser Nothing)

addCommand' "run"

"Build and run an executable. Defaults to the first available executable if none is provided as the first argument."

execCmd

(execOptsParser $ Just ExecRun)

addGhciCommand' "ghci"

"Run ghci in the context of package(s) (experimental)"

ghciCmd

ghciOptsParser

addGhciCommand' "repl"

"Run ghci in the context of package(s) (experimental) (alias for 'ghci')"

ghciCmd

ghciOptsParser

addCommand' "runghc"

"Run runghc"

execCmd

(execOptsParser $ Just ExecRunGhc)

addCommand' "runhaskell"

"Run runghc (alias for 'runghc')"

execCmd

(execOptsParser $ Just ExecRunGhc)

addCommand "script"

"Run a Stack Script"

globalFooter

scriptCmd

(\so gom ->

gom

{ globalMonoidResolverRoot = First $ Just $ takeDirectory $ soFile so

})

(globalOpts OtherCmdGlobalOpts)

scriptOptsParser

addCommand' "freeze"

"Show project or snapshot with pinned dependencies if there are any such (experimental, may be removed)"

freezeCmd

freezeOptsParser

unless isInterpreter (do

addCommand' "eval"

"Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"

evalCmd

(evalOptsParser "CODE")

addCommand' "clean"

"Delete build artefacts for the project packages."

cleanCmd

(cleanOptsParser Clean)

addCommand' "purge"

"Delete the project stack working directories (.stack-work by default). Shortcut for 'stack clean --full'"

cleanCmd

(cleanOptsParser Purge)

addCommand' "query"

"Query general build information (experimental)"

queryCmd

(many $ strArgument $ metavar "SELECTOR...")

addSubCommands'

"ide"

"IDE-specific commands"

(let outputFlag = flag

IDE.OutputLogInfo

IDE.OutputStdout

(long "stdout" <>

help "Send output to stdout instead of the default, stderr")

cabalFileFlag = flag

IDE.ListPackageNames

IDE.ListPackageCabalFiles

(long "cabal-files" <>

help "Print paths to package cabal-files instead of package names")

in

do addCommand'

"packages"

"List all available local loadable packages"

idePackagesCmd

((,) <$> outputFlag <*> cabalFileFlag)

addCommand'

"targets"

"List all available stack targets"

ideTargetsCmd

outputFlag)

addSubCommands'

Docker.dockerCmdName

"Subcommands specific to Docker use"

(do addCommand' Docker.dockerPullCmdName

"Pull latest version of Docker image from registry"

dockerPullCmd

(pure ())

addCommand' "reset"

"Reset the Docker sandbox"

dockerResetCmd

(switch (long "keep-home" <>

help "Do not delete sandbox's home directory")))

addSubCommands'

ConfigCmd.cfgCmdName

"Subcommands for accessing and modifying configuration values"

(do

addCommand' ConfigCmd.cfgCmdSetName

"Sets a field in the project's stack.yaml to value"

(withConfig NoReexec . cfgCmdSet)

configCmdSetParser

addCommand' ConfigCmd.cfgCmdEnvName

"Print environment variables for use in a shell"

(withConfig YesReexec . withDefaultEnvConfig . cfgCmdEnv)

configCmdEnvParser)

addSubCommands'

"hpc"

"Subcommands specific to Haskell Program Coverage"

(addCommand' "report"

"Generate unified HPC coverage report from tix files and project targets"

hpcReportCmd

hpcReportOptsParser)

)

where

-- addCommand hiding global options

addCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a

-> AddCommand

addCommand' cmd title constr =

addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts OtherCmdGlobalOpts)

addSubCommands' :: String -> String -> AddCommand

-> AddCommand

addSubCommands' cmd title =

addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts)

-- Additional helper that hides global options and shows build options

addBuildCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a

-> AddCommand

addBuildCommand' cmd title constr =

addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts BuildCmdGlobalOpts)

-- Additional helper that hides global options and shows some ghci options

addGhciCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a

-> AddCommand

addGhciCommand' cmd title constr =

addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts GhciCmdGlobalOpts)

globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid

globalOpts kind =

extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>

extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>

globalOptsParser currentDir kind

(if isInterpreter

-- Silent except when errors occur - see #2879

then Just LevelError

else Nothing)

where hide = kind /= OuterGlobalOpts

globalFooter = "Run 'stack --help' for global options that apply to all subcommands."

type AddCommand =

ExceptT (RIO Runner ()) (Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid))) ()

-- | fall-through to external executables in `git` style if they exist

-- (i.e. `stack something` looks for `stack-something` before

-- failing with "Invalid argument `something'")

secondaryCommandHandler

:: [String]

-> ParserFailure ParserHelp

-> IO (ParserFailure ParserHelp)

secondaryCommandHandler args f =

-- don't even try when the argument looks like a path or flag

if elem pathSeparator cmd || "-" `isPrefixOf` head args

then return f

else do

mExternalExec <- D.findExecutable cmd

case mExternalExec of

Just ex -> withProcessContextNoLogging $ do

-- TODO show the command in verbose mode

-- hPutStrLn stderr $ unwords $

-- ["Running", "[" ++ ex, unwords (tail args) ++ "]"]

_ <- exec ex (tail args)

return f

Nothing -> return $ fmap (vcatErrorHelp (noSuchCmd cmd)) f

where

-- FIXME this is broken when any options are specified before the command

-- e.g. stack --verbosity silent cmd

cmd = stackProgName ++ "-" ++ head args

noSuchCmd name = errorHelp $ stringChunk

("Auxiliary command not found in path `" ++ name ++ "'")

interpreterHandler

:: Monoid t

=> FilePath

-> [String]

-> ParserFailure ParserHelp

-> IO (GlobalOptsMonoid, (RIO Runner (), t))

interpreterHandler currentDir args f = do

-- args can include top-level config such as --extra-lib-dirs=... (set by

-- nix-shell) - we need to find the first argument which is a file, everything

-- afterwards is an argument to the script, everything before is an argument

-- to Stack

(stackArgs, fileArgs) <- spanM (fmap not . D.doesFileExist) args

case fileArgs of

(file:fileArgs') -> runInterpreterCommand file stackArgs fileArgs'

[] -> parseResultHandler (errorCombine (noSuchFile firstArg))

where

firstArg = head args

spanM _ [] = return ([], [])

spanM p xs@(x:xs') = do

r <- p x

if r

then do

(ys, zs) <- spanM p xs'

return (x:ys, zs)

else

return ([], xs)

-- if the first argument contains a path separator then it might be a file,

-- or a Stack option referencing a file. In that case we only show the

-- interpreter error message and exclude the command related error messages.

errorCombine =

if pathSeparator `elem` firstArg

then overrideErrorHelp

else vcatErrorHelp

overrideErrorHelp h1 h2 = h2 { helpError = helpError h1 }

parseResultHandler fn = handleParseResult (overFailure fn (Failure f))

noSuchFile name = errorHelp $ stringChunk

("File does not exist or is not a regular file `" ++ name ++ "'")

runInterpreterCommand path stackArgs fileArgs = do

progName <- getProgName

iargs <- getInterpreterArgs path

let parseCmdLine = commandLineHandler currentDir progName True

-- Implicit file arguments are put before other arguments that

-- occur after "--". See #3658

cmdArgs = stackArgs ++ case break (== "--") iargs of

(beforeSep, []) -> beforeSep ++ ["--"] ++ [path] ++ fileArgs

(beforeSep, optSep : afterSep) ->

beforeSep ++ [optSep] ++ [path] ++ fileArgs ++ afterSep

-- TODO show the command in verbose mode

-- hPutStrLn stderr $ unwords $

-- ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]

(a,b) <- withArgs cmdArgs parseCmdLine

return (a,(b,mempty))

setupCmd :: SetupCmdOpts -> RIO Runner ()

setupCmd sco@SetupCmdOpts{..} = withConfig YesReexec $ do

(wantedCompiler, compilerCheck, mstack) <-

case scoCompilerVersion of

Just v -> return (v, MatchMinor, Nothing)

Nothing -> withBuildConfig $ (,,)

<$> view wantedCompilerVersionL

<*> view (configL.to configCompilerCheck)

<*> (Just <$> view stackYamlL)

setup sco wantedCompiler compilerCheck mstack

cleanCmd :: CleanOpts -> RIO Runner ()

cleanCmd = withConfig NoReexec . withBuildConfig . clean

-- | Helper for build and install commands

buildCmd :: BuildOptsCLI -> RIO Runner ()

buildCmd opts = do

when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do

logError "Error: When building with stack, you should not use the -prof GHC option"

logError "Instead, please use --library-profiling and --executable-profiling"

logError "See: https://github.com/commercialhaskell/stack/issues/1015"

exitFailure

local (over globalOptsL modifyGO) $

case boptsCLIFileWatch opts of

FileWatchPoll -> fileWatchPoll stderr (inner . Just)

FileWatch -> fileWatch stderr (inner . Just)

NoFileWatch -> inner Nothing

where

inner

:: Maybe (Set (Path Abs File) -> IO ())

-> RIO Runner ()

inner setLocalFiles = withConfig YesReexec $ withEnvConfig NeedTargets opts $

Stack.Build.build setLocalFiles

-- Read the build command from the CLI and enable it to run

modifyGO =

case boptsCLICommand opts of

Test -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True)

Haddock -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just True)

Bench -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True)

Install -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidInstallExesL) (Just True)

Build -> id -- Default case is just Build

uninstallCmd :: [String] -> RIO Runner ()

uninstallCmd _ = do

prettyErrorL

[ flow "stack does not manage installations in global locations."

, flow "The only global mutation stack performs is executable copying."

, flow "For the default executable destination, please run"

, PP.style Shell "stack path --local-bin"

]

liftIO exitFailure

-- | Unpack packages to the filesystem

unpackCmd :: ([String], Maybe Text) -> RIO Runner ()

unpackCmd (names, Nothing) = unpackCmd (names, Just ".")

unpackCmd (names, Just dstPath) = withConfig NoReexec $ do

mresolver <- view $ globalOptsL.to globalResolver

mSnapshot <- forM mresolver $ \resolver -> do

concrete <- makeConcreteResolver resolver

loc <- completeSnapshotLocation concrete

loadSnapshot loc

dstPath' <- resolveDir' $ T.unpack dstPath

unpackPackages mSnapshot dstPath' names

-- | Update the package index

updateCmd :: () -> RIO Runner ()

updateCmd () = withConfig NoReexec (void (updateHackageIndex Nothing))

upgradeCmd :: UpgradeOpts -> RIO Runner ()

upgradeCmd upgradeOpts' = do

go <- view globalOptsL

case globalResolver go of

Just _ -> do

logError "You cannot use the --resolver option with the upgrade command"

liftIO exitFailure

Nothing ->

withGlobalProject $

upgrade

maybeGitHash

upgradeOpts'

-- | Upload to Hackage

uploadCmd :: SDistOpts -> RIO Runner ()

uploadCmd (SDistOpts [] _ _ _ _) = do

prettyErrorL

[ flow "To upload the current package, please run"

, PP.style Shell "stack upload ."

, flow "(with the period at the end)"

]

liftIO exitFailure

uploadCmd sdistOpts = do

let partitionM _ [] = return ([], [])

partitionM f (x:xs) = do

r <- f x

(as, bs) <- partitionM f xs

return $ if r then (x:as, bs) else (as, x:bs)

(files, nonFiles) <- liftIO $ partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)

(dirs, invalid) <- liftIO $ partitionM D.doesDirectoryExist nonFiles

withConfig YesReexec $ withDefaultEnvConfig $ do

unless (null invalid) $ do

let invalidList = bulletedList $ map (PP.style File . fromString) invalid

prettyErrorL

[ PP.style Shell "stack upload"

, flow "expects a list of sdist tarballs or package directories."

, flow "Can't find:"

, line <> invalidList

]

exitFailure

when (null files && null dirs) $ do

prettyErrorL

[ PP.style Shell "stack upload"

, flow "expects a list of sdist tarballs or package directories, but none were specified."

]

exitFailure

config <- view configL

let hackageUrl = T.unpack $ configHackageBaseUrl config

getCreds <- liftIO $ memoizeRef $ Upload.loadCreds config

mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files

forM_

files

(\file ->

do tarFile <- resolveFile' file

liftIO $ do

creds <- runMemoized getCreds

Upload.upload hackageUrl creds (toFilePath tarFile))

unless (null dirs) $

forM_ dirs $ \dir -> do

pkgDir <- resolveDir' dir

(tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir

checkSDistTarball' sdistOpts tarName tarBytes

liftIO $ do

creds <- runMemoized getCreds

Upload.uploadBytes hackageUrl creds tarName tarBytes

forM_ mcabalRevision $ uncurry $ Upload.uploadRevision hackageUrl creds

sdistCmd :: SDistOpts -> RIO Runner ()

sdistCmd sdistOpts =

withConfig YesReexec $ withDefaultEnvConfig $ do

-- If no directories are specified, build all sdist tarballs.

dirs' <- if null (sdoptsDirsToWorkWith sdistOpts)

then do

dirs <- view $ buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)

when (null dirs) $ do

stackYaml <- view stackYamlL

prettyErrorL

[ PP.style Shell "stack sdist"

, flow "expects a list of targets, and otherwise defaults to all of the project's packages."

, flow "However, the configuration at"

, pretty stackYaml

, flow "contains no packages, so no sdist tarballs will be generated."

]

exitFailure

return dirs

else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts)

forM_ dirs' $ \dir -> do

(tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir

distDir <- distDirFromDir dir

tarPath <- (distDir </>) <$> parseRelFile tarName

ensureDir (parent tarPath)

runConduitRes $

sourceLazy tarBytes .|

sinkFileCautious (toFilePath tarPath)

prettyInfoL [flow "Wrote sdist tarball to", pretty tarPath]

checkSDistTarball sdistOpts tarPath

forM_ (sdoptsTarPath sdistOpts) $ copyTarToTarPath tarPath tarName

where

copyTarToTarPath tarPath tarName targetDir = liftIO $ do

let targetTarPath = targetDir FP.</> tarName

D.createDirectoryIfMissing True $ FP.takeDirectory targetTarPath

D.copyFile (toFilePath tarPath) targetTarPath

-- | Execute a command.

execCmd :: ExecOpts -> RIO Runner ()

execCmd ExecOpts {..} =

withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do

unless (null targets) $ Stack.Build.build Nothing

config <- view configL

menv <- liftIO $ configProcessContextSettings config eoEnvSettings

withProcessContext menv $ do

-- Add RTS options to arguments

let argsWithRts args = if null eoRtsOptions

then args :: [String]

else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"]

(cmd, args) <- case (eoCmd, argsWithRts eoArgs) of

(ExecCmd cmd, args) -> return (cmd, args)

(ExecRun, args) -> getRunCmd args

(ExecGhc, args) -> getGhcCmd eoPackages args

-- NOTE: This doesn't work for GHCJS, because it doesn't have

-- a runghcjs binary.

(ExecRunGhc, args) -> getRunGhcCmd eoPackages args

runWithPath eoCwd $ exec cmd args

where

ExecOptsExtra {..} = eoExtra

targets = concatMap words eoPackages

boptsCLI = defaultBuildOptsCLI

{ boptsCLITargets = map T.pack targets

}

-- return the package-id of the first package in GHC_PACKAGE_PATH

getPkgId name = do

pkg <- getGhcPkgExe

mId <- findGhcPkgField pkg [] name "id"

case mId of

Just i -> return (head $ words (T.unpack i))

-- should never happen as we have already installed the packages

_ -> do

logError ("Could not find package id of package " <> fromString name)

exitFailure

getPkgOpts pkgs =

map ("-package-id=" ++) <$> mapM getPkgId pkgs

getRunCmd args = do

packages <- view $ buildConfigL.to (smwProject . bcSMWanted)

pkgComponents <- for (Map.elems packages) ppComponents

let executables = filter isCExe $ concatMap Set.toList pkgComponents

let (exe, args') = case args of

[] -> (firstExe, args)

x:xs -> case find (\y -> y == CExe (T.pack x)) executables of

Nothing -> (firstExe, args)

argExe -> (argExe, xs)

where

firstExe = listToMaybe executables

case exe of

Just (CExe exe') -> do

withNewLocalBuildTargets [T.cons ':' exe'] $ Stack.Build.build Nothing

return (T.unpack exe', args')

_ -> do

logError "No executables found."

exitFailure

getGhcCmd pkgs args = do

pkgopts <- getPkgOpts pkgs

compiler <- view $ compilerPathsL.to cpCompiler

return (toFilePath compiler, pkgopts ++ args)

getRunGhcCmd pkgs args = do

pkgopts <- getPkgOpts pkgs

interpret <- view $ compilerPathsL.to cpInterpreter

return (toFilePath interpret, pkgopts ++ args)

runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()

runWithPath path callback = case path of

Nothing -> callback

Just p | not (isValid p) -> throwIO $ InvalidPathForExec p

Just p -> withUnliftIO $ \ul -> D.withCurrentDirectory p $ unliftIO ul callback

-- | Evaluate some haskell code inline.

evalCmd :: EvalOpts -> RIO Runner ()

evalCmd EvalOpts {..} = execCmd execOpts

where

execOpts =

ExecOpts { eoCmd = ExecGhc

, eoArgs = ["-e", evalArg]

, eoExtra = evalExtra

}

-- | Run GHCi in the context of a project.

ghciCmd :: GhciOpts -> RIO Runner ()

ghciCmd ghciOpts =

let boptsCLI = defaultBuildOptsCLI

-- using only additional packages, targets then get overriden in `ghci`

{ boptsCLITargets = map T.pack (ghciAdditionalPackages ghciOpts)

, boptsCLIInitialBuildSteps = True

, boptsCLIFlags = ghciFlags ghciOpts

, boptsCLIGhcOptions = map T.pack (ghciGhcOptions ghciOpts)

}

in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do

bopts <- view buildOptsL

-- override env so running of tests and benchmarks is disabled

let boptsLocal = bopts

{ boptsTestOpts = (boptsTestOpts bopts) { toDisableRun = True }

, boptsBenchmarkOpts = (boptsBenchmarkOpts bopts) { beoDisableRun = True }

}

local (set buildOptsL boptsLocal)

(ghci ghciOpts)

-- | List packages in the project.

idePackagesCmd :: (IDE.OutputStream, IDE.ListPackagesCmd) -> RIO Runner ()

idePackagesCmd = withConfig NoReexec . withBuildConfig . uncurry IDE.listPackages

-- | List targets in the project.

ideTargetsCmd :: IDE.OutputStream -> RIO Runner ()

ideTargetsCmd = withConfig NoReexec . withBuildConfig . IDE.listTargets

-- | Pull the current Docker image.

dockerPullCmd :: () -> RIO Runner ()

dockerPullCmd () = withConfig NoReexec $ Docker.preventInContainer Docker.pull

-- | Reset the Docker sandbox.

dockerResetCmd :: Bool -> RIO Runner ()

dockerResetCmd = withConfig NoReexec . Docker.preventInContainer . Docker.reset

-- | Project initialization

initCmd :: InitOpts -> RIO Runner ()

initCmd initOpts = do

pwd <- getCurrentDir

go <- view globalOptsL

withGlobalProject $ withConfig YesReexec (initProject pwd initOpts (globalResolver go))

-- | Create a project directory structure and initialize the stack config.

newCmd :: (NewOpts,InitOpts) -> RIO Runner ()

newCmd (newOpts,initOpts) =

withGlobalProject $ withConfig YesReexec $ do

dir <- new newOpts (forceOverwrite initOpts)

exists <- doesFileExist $ dir </> stackDotYaml

when (forceOverwrite initOpts || not exists) $ do

go <- view globalOptsL

initProject dir initOpts (globalResolver go)

-- | Display instructions for how to use templates

templatesCmd :: () -> RIO Runner ()

templatesCmd () = withConfig NoReexec templatesHelp

-- | Query build information

queryCmd :: [String] -> RIO Runner ()

queryCmd selectors = withConfig YesReexec $ withDefaultEnvConfig $ queryBuildInfo $ map T.pack selectors

-- | Generate a combined HPC report

hpcReportCmd :: HpcReportOpts -> RIO Runner ()

hpcReportCmd hropts = do

let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs hropts)

boptsCLI = defaultBuildOptsCLI

{ boptsCLITargets = if hroptsAll hropts then [] else targetNames }

withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $

generateHpcReportForTargets hropts tixFiles targetNames

freezeCmd :: FreezeOpts -> RIO Runner ()

freezeCmd freezeOpts = withConfig YesReexec $ withDefaultEnvConfig $ freeze freezeOpts

data MainException = InvalidReExecVersion String String

| InvalidPathForExec FilePath

deriving (Typeable)

instance Exception MainException

instance Show MainException where

show (InvalidReExecVersion expected actual) = concat

[ "When re-executing '"

, stackProgName

, "' in a container, the incorrect version was found\nExpected: "

, expected

, "; found: "

, actual]

show (InvalidPathForExec path) = concat

[ "Got an invalid --cwd argument for stack exec ("

, path

, ")"]