{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | Main Stack tool entry point.


module Stack
  ( main
  ) where

import           GHC.IO.Encoding ( mkTextEncoding, textEncodingName )
import           Options.Applicative.Builder.Extra ( execExtraHelp )
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 ( 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 (Int -> StackException -> ShowS
[StackException] -> ShowS
StackException -> [Char]
(Int -> StackException -> ShowS)
-> (StackException -> [Char])
-> ([StackException] -> ShowS)
-> Show StackException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StackException -> ShowS
showsPrec :: Int -> StackException -> ShowS
$cshow :: StackException -> [Char]
show :: StackException -> [Char]
$cshowList :: [StackException] -> ShowS
showList :: [StackException] -> ShowS
Show, Typeable)

instance Exception StackException where
  displayException :: StackException -> [Char]
displayException (InvalidReExecVersion [Char]
expected [Char]
actual) = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"Error: [S-2186]\n"
    , [Char]
"When re-executing '"
    , [Char]
stackProgName
    , [Char]
"' in a container, the incorrect version was found\nExpected: "
    , [Char]
expected
    , [Char]
"; found: "
    , [Char]
actual
    ]

main :: IO ()
main :: IO ()
main = do
  -- Line buffer the output by default, particularly for non-terminal runs.

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

  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdin  BufferMode
LineBuffering
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
  Handle -> IO ()
hSetTranslit Handle
stdout
  Handle -> IO ()
hSetTranslit Handle
stderr
  [[Char]]
args <- IO [[Char]]
getArgs
  [Char]
progName <- IO [Char]
getProgName
  Bool
isTerminal <- Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stdout
  [[Char]] -> [Char] -> Parser DockerOptsMonoid -> [Char] -> IO ()
forall a. [[Char]] -> [Char] -> Parser a -> [Char] -> IO ()
execExtraHelp
    [[Char]]
args
    [Char]
dockerHelpOptName
    (Bool -> Parser DockerOptsMonoid
dockerOptsParser Bool
False)
    ([Char]
"Only showing --" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
dockerCmdName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"* options.")
  [[Char]] -> [Char] -> Parser NixOptsMonoid -> [Char] -> IO ()
forall a. [[Char]] -> [Char] -> Parser a -> [Char] -> IO ()
execExtraHelp
    [[Char]]
args
    [Char]
nixHelpOptName
    (Bool -> Parser NixOptsMonoid
nixOptsParser Bool
False)
    ([Char]
"Only showing --" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
nixCmdName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"* options.")
  [Char]
currentDir <- IO [Char]
getCurrentDirectory
  Either ExitCode (GlobalOptsMonoid, RIO Runner ())
eGlobalRun <- IO (GlobalOptsMonoid, RIO Runner ())
-> IO (Either ExitCode (GlobalOptsMonoid, RIO Runner ()))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO (GlobalOptsMonoid, RIO Runner ())
 -> IO (Either ExitCode (GlobalOptsMonoid, RIO Runner ())))
-> IO (GlobalOptsMonoid, RIO Runner ())
-> IO (Either ExitCode (GlobalOptsMonoid, RIO Runner ()))
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Bool -> IO (GlobalOptsMonoid, RIO Runner ())
commandLineHandler [Char]
currentDir [Char]
progName Bool
False
  case Either ExitCode (GlobalOptsMonoid, RIO Runner ())
eGlobalRun of
    Left (ExitCode
exitCode :: ExitCode) ->
      ExitCode -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ExitCode
exitCode
    Right (GlobalOptsMonoid
globalMonoid, RIO Runner ()
run) -> do
      GlobalOpts
global <- Bool -> GlobalOptsMonoid -> IO GlobalOpts
forall (m :: * -> *).
MonadIO m =>
Bool -> GlobalOptsMonoid -> m GlobalOpts
globalOptsFromMonoid Bool
isTerminal GlobalOptsMonoid
globalMonoid
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GlobalOpts
global.logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
LevelDebug) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
versionString'
      case GlobalOpts
global.reExecVersion of
        Just [Char]
expectVersion -> do
          Version
expectVersion' <- [Char] -> IO Version
forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing [Char]
expectVersion
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VersionCheck -> Version -> Version -> Bool
checkVersion VersionCheck
MatchMinor Version
expectVersion' Version
stackVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            StackException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (StackException -> IO ()) -> StackException -> IO ()
forall a b. (a -> b) -> a -> b
$
              [Char] -> [Char] -> StackException
InvalidReExecVersion [Char]
expectVersion [Char]
showStackVersion
        Maybe [Char]
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      GlobalOpts -> RIO Runner () -> IO ()
forall a. GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal GlobalOpts
global (RIO Runner () -> IO ()) -> RIO Runner () -> IO ()
forall a b. (a -> b) -> a -> b
$ RIO Runner ()
run RIO Runner () -> [Handler (RIO Runner) ()] -> RIO Runner ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`catches`
        [ (ExitCode -> RIO Runner ()) -> Handler (RIO Runner) ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ExitCode -> RIO Runner ()
forall a. ExitCode -> RIO Runner a
handleExitCode
        , (PrettyException -> RIO Runner ()) -> Handler (RIO Runner) ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler PrettyException -> RIO Runner ()
forall a. PrettyException -> RIO Runner a
handlePrettyException
        , (PantryException -> RIO Runner ()) -> Handler (RIO Runner) ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler PantryException -> RIO Runner ()
forall a. PantryException -> RIO Runner a
handlePantryException
        , (SomeException -> RIO Runner ()) -> Handler (RIO Runner) ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler SomeException -> RIO Runner ()
forall a. SomeException -> RIO Runner a
handleSomeException
        ]

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

-- unsupported characters instead of throwing an exception

hSetTranslit :: Handle -> IO ()
hSetTranslit :: Handle -> IO ()
hSetTranslit Handle
h = do
  Maybe TextEncoding
menc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  case (TextEncoding -> [Char]) -> Maybe TextEncoding -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> [Char]
textEncodingName Maybe TextEncoding
menc of
    Just [Char]
name
      | Char
'/' Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char]
name -> do
          TextEncoding
enc' <- [Char] -> IO TextEncoding
mkTextEncoding ([Char] -> IO TextEncoding) -> [Char] -> IO TextEncoding
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"//TRANSLIT"
          Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
enc'
    Maybe [Char]
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Handle ExitCode exceptions.

handleExitCode :: ExitCode -> RIO Runner a
handleExitCode :: forall a. ExitCode -> RIO Runner a
handleExitCode = ExitCode -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith

-- | Handle PrettyException exceptions.

handlePrettyException :: PrettyException -> RIO Runner a
handlePrettyException :: forall a. PrettyException -> RIO Runner a
handlePrettyException = PrettyException -> RIO Runner a
forall e a. (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException

-- | Handle (pretty) PantryException exceptions.

handlePantryException :: PantryException -> RIO Runner a
handlePantryException :: forall a. PantryException -> RIO Runner a
handlePantryException = PantryException -> RIO Runner a
forall e a. (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException

-- | Handle any pretty exception.

handleAnyPrettyException :: (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException :: forall e a. (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException e
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.

  Either SomeException ()
result <- RIO Runner () -> RIO Runner (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO Runner () -> RIO Runner (Either SomeException ()))
-> RIO Runner () -> RIO Runner (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ StyleDoc -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO Config ()) -> StyleDoc -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
e
  case Either SomeException ()
result of
    -- Falls back to the command line's Stack colours if there is any error in

    -- loading the entire Stack configuration.

    Left SomeException
_ -> StyleDoc -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO Runner ()) -> StyleDoc -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
e
    Right ()
_ -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  RIO Runner a
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

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

-- being printed before the exception.

handleSomeException :: SomeException -> RIO Runner a
handleSomeException :: forall a. SomeException -> RIO Runner a
handleSomeException (SomeException e
e) = do
  Utf8Builder -> RIO Runner ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO Runner ()) -> Utf8Builder -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder) -> [Char] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
e
  RIO Runner a
forall (m :: * -> *) a. MonadIO m => m a
exitFailure