{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE OverloadedRecordDot #-}

{-# LANGUAGE OverloadedStrings #-}

{-|

Module : Stack

Description : Main Stack tool entry point.

License : BSD-3-Clause

Main Stack tool entry point.

-}

module Stack

( main

) where

import Control.Monad.Extra ( whenJust )

import GHC.IO.Encoding ( mkTextEncoding, textEncodingName )

import Options.Applicative.Builder.Extra ( execExtraHelp )

import Path ( parseAbsFile )

import Stack.BuildInfo ( versionString' )

import Stack.CLI ( commandLineHandler )

import Stack.Constants ( stackProgName )

import Stack.Docker ( dockerCmdName, dockerHelpOptName )

import Stack.Nix ( nixCmdName, nixHelpOptName )

import Stack.Options.DockerParser ( dockerOptsParser )

import Stack.Options.GlobalParser ( globalOptsFromMonoid )

import Stack.Options.NixParser ( nixOptsParser )

import Stack.Prelude

import Stack.Runners

( ShouldReexec (..), withConfig, withRunnerGlobal )

import Stack.Types.GlobalOpts ( GlobalOpts (..) )

import Stack.Types.Runner ( Runner )

import Stack.Types.Version

( VersionCheck (..), checkVersion, showStackVersion

, stackVersion

)

import System.Directory ( getCurrentDirectory )

import System.Environment ( executablePath, getArgs, getProgName )

import System.IO ( hGetEncoding, hPutStrLn, hSetEncoding )

import System.Terminal ( hIsTerminalDeviceOrMinTTY )

-- | Type representing exceptions thrown by functions in the "Stack" module.

data StackException

= InvalidReExecVersion String String

deriving Show

instance Exception StackException where

displayException (InvalidReExecVersion expected actual) = concat

[ "Error: [S-2186]\n"

, "When re-executing '"

, stackProgName

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

, expected

, "; found: "

, actual

]

-- | Main Stack tool entry point.

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

mExecutableFilePath <- fromMaybe (pure Nothing) executablePath

let mExecutablePath = mExecutableFilePath >>= parseAbsFile

isTerminal <- hIsTerminalDeviceOrMinTTY stdout

execExtraHelp

args

dockerHelpOptName

(dockerOptsParser False)

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

execExtraHelp

args

nixHelpOptName

(nixOptsParser False)

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

currentDir <- getCurrentDirectory

try (commandLineHandler currentDir progName mExecutablePath False) >>= \case

Left (exitCode :: ExitCode) ->

throwIO exitCode

Right (globalMonoid, run) -> do

global <-

globalOptsFromMonoid progName mExecutablePath isTerminal globalMonoid

when (global.logLevel == LevelDebug) $

hPutStrLn stderr versionString'

whenJust global.reExecVersion $ \expectVersion -> do

expectVersion' <- parseVersionThrowing expectVersion

unless (checkVersion MatchMinor expectVersion' stackVersion) $

throwIO $ InvalidReExecVersion expectVersion showStackVersion

withRunnerGlobal global $ run `catches`

[ Handler handleExitCode

, Handler handlePrettyException

, Handler handlePantryException

, Handler handleSomeException

]

-- | 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

whenJust (fmap textEncodingName menc) $ \name ->

unless ('/' `elem` name) $ do

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

hSetEncoding h enc'

-- | Handle ExitCode exceptions.

handleExitCode :: ExitCode -> RIO Runner a

handleExitCode = exitWith

-- | Handle PrettyException exceptions.

handlePrettyException :: PrettyException -> RIO Runner a

handlePrettyException = handleAnyPrettyException

-- | Handle (pretty) PantryException exceptions.

handlePantryException :: PantryException -> RIO Runner a

handlePantryException = handleAnyPrettyException

-- | Handle any pretty exception.

handleAnyPrettyException :: (Exception e, Pretty e) => e -> RIO Runner a

handleAnyPrettyException e = do

-- The code below loads the entire Stack configuration, when all that is

-- needed are the Stack colours. A tailored approach may be better.

tryAny (withConfig NoReexec $ prettyError $ pretty e) >>= \case

-- Falls back to the command line's Stack colours if there is any error in

-- loading the entire Stack configuration.

Left _ -> prettyError $ pretty e

Right _ -> pure ()

exitFailure

-- | Handle SomeException exceptions. This special handler stops "stack: " from

-- being printed before the exception.

handleSomeException :: SomeException -> RIO Runner a

handleSomeException (SomeException e) = do

logError $ fromString $ displayException e

exitFailure