Exec.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- | Types and function related to Stack's @exec@, @ghc@, @run@, @runghc@ and
-- @runhaskell@ commands.
module Stack.Exec
  ( ExecOpts (..)
  , SpecialExecCmd (..)
  , ExecOptsExtra (..)
  , execCmd
  ) where

import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           RIO.Process ( exec )
import           Stack.Build ( build )
import           Stack.Build.Target ( NeedTargets (..) )
import           Stack.GhcPkg ( findGhcPkgField )
import           Stack.Setup ( withNewLocalBuildTargets )
import           Stack.Types.NamedComponent ( NamedComponent (..), isCExe )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.BuildOpts
                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..), getGhcPkgExe )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.EnvConfig ( EnvConfig )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.Runner ( Runner )
import           Stack.Types.SourceMap ( SMWanted (..), ppComponents )
import           System.Directory ( withCurrentDirectory )
import           System.FilePath ( isValid )

-- | Type representing exceptions thrown by functions in the "Stack.Exec"
-- module.
newtype ExecException
  = InvalidPathForExec FilePath
  deriving (Show, Typeable)

instance Exception ExecException where
  displayException (InvalidPathForExec path) = concat
    [ "Error: [S-1541]\n"
    , "Got an invalid '--cwd' argument for 'stack exec' ("
    , path
    , ")."
    ]

-- | Type representing \'pretty\' exceptions thrown by functions in the
-- "Stack.Exec" module.
data ExecPrettyException
  = PackageIdNotFoundBug !String
  | ExecutableToRunNotFound
  deriving (Show, Typeable)

instance Pretty ExecPrettyException where
  pretty (PackageIdNotFoundBug name) = bugPrettyReport "[S-8251]" $
    "Could not find the package id of the package" <+>
      style Target (fromString name)
    <> "."
  pretty ExecutableToRunNotFound =
       "[S-2483]"
    <> line
    <> flow "No executables found."

instance Exception ExecPrettyException

-- Type representing Stack's execution commands.
data SpecialExecCmd
  = ExecCmd String
  | ExecRun
  | ExecGhc
  | ExecRunGhc
  deriving (Eq, Show)

data ExecOptsExtra = ExecOptsExtra
  { eoEnvSettings :: !EnvSettings
  , eoPackages :: ![String]
  , eoRtsOptions :: ![String]
  , eoCwd :: !(Maybe FilePath)
  }
  deriving Show

-- Type representing options for Stack's execution commands.
data ExecOpts = ExecOpts
  { eoCmd :: !SpecialExecCmd
  , eoArgs :: ![String]
  , eoExtra :: !ExecOptsExtra
  }
  deriving Show

-- | The function underlying Stack's @exec@, @ghc@, @run@, @runghc@ and
-- @runhaskell@ commands. Execute a command.
execCmd :: ExecOpts -> RIO Runner ()
execCmd ExecOpts {..} =
  withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
    unless (null targets) $ 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) -> pure (cmd, args)
        (ExecRun, args) -> getRunCmd args
        (ExecGhc, args) -> getGhcCmd eoPackages args
        (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 -> pure (L.head $ words (T.unpack i))
      -- should never happen as we have already installed the packages
      _      -> prettyThrowIO (PackageIdNotFoundBug name)

  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 = concatMap (filter isCExe . Set.toList) pkgComponents
    let (exe, args') = case args of
                       []   -> (firstExe, args)
                       x:xs -> case L.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'] $ build Nothing
        pure (T.unpack exe', args')
      _ -> prettyThrowIO ExecutableToRunNotFound

  getGhcCmd pkgs args = do
    pkgopts <- getPkgOpts pkgs
    compiler <- view $ compilerPathsL.to cpCompiler
    pure (toFilePath compiler, pkgopts ++ args)

  getRunGhcCmd pkgs args = do
    pkgopts <- getPkgOpts pkgs
    interpret <- view $ compilerPathsL.to cpInterpreter
    pure (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 -> withCurrentDirectory p $ unliftIO ul callback