505 lines
17 KiB
Haskell
505 lines
17 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
module GHCup.OptParse.Run where
|
|
|
|
|
|
import GHCup
|
|
import GHCup.Utils
|
|
import GHCup.OptParse.Common
|
|
import GHCup.Errors
|
|
import GHCup.Types
|
|
import GHCup.Types.Optics
|
|
import GHCup.Prelude
|
|
import GHCup.Prelude.File
|
|
#ifdef IS_WINDOWS
|
|
import GHCup.Prelude.Process
|
|
import GHCup.Prelude.Process.Windows ( execNoMinGW )
|
|
#endif
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Prelude.String.QQ
|
|
|
|
import Control.Exception.Safe ( MonadMask, MonadCatch )
|
|
#if !MIN_VERSION_base(4,13,0)
|
|
import Control.Monad.Fail ( MonadFail )
|
|
#endif
|
|
import Codec.Archive
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Resource
|
|
import Data.Functor
|
|
import Data.Maybe (isNothing)
|
|
import Data.List ( intercalate )
|
|
import Haskus.Utils.Variant.Excepts
|
|
import Options.Applicative hiding ( style )
|
|
import Prelude hiding ( appendFile )
|
|
import System.FilePath
|
|
import System.Environment
|
|
import System.Exit
|
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
#ifndef IS_WINDOWS
|
|
import qualified System.Posix.Process as SPP
|
|
#endif
|
|
import Data.Versions ( prettyVer, Version )
|
|
|
|
|
|
|
|
|
|
|
|
---------------
|
|
--[ Options ]--
|
|
---------------
|
|
|
|
|
|
data RunOptions = RunOptions
|
|
{ runAppendPATH :: Bool
|
|
, runInstTool' :: Bool
|
|
, runMinGWPath :: Bool
|
|
, runGHCVer :: Maybe ToolVersion
|
|
, runCabalVer :: Maybe ToolVersion
|
|
, runHLSVer :: Maybe ToolVersion
|
|
, runStackVer :: Maybe ToolVersion
|
|
, runBinDir :: Maybe FilePath
|
|
, runQuick :: Bool
|
|
, runCOMMAND :: [String]
|
|
}
|
|
|
|
|
|
|
|
---------------
|
|
--[ Parsers ]--
|
|
---------------
|
|
|
|
|
|
|
|
runOpts :: Parser RunOptions
|
|
runOpts =
|
|
RunOptions
|
|
<$> switch
|
|
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
|
|
<*> switch
|
|
(short 'i' <> long "install" <> help "Install the tool, if missing")
|
|
<*> switch
|
|
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
|
|
<*> optional
|
|
(option
|
|
(eitherReader ghcVersionTagEither)
|
|
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
|
|
<> completer (tagCompleter GHC [])
|
|
<> (completer $ versionCompleter Nothing GHC)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader toolVersionTagEither)
|
|
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
|
|
<> completer (tagCompleter Cabal [])
|
|
<> (completer $ versionCompleter Nothing Cabal)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader toolVersionTagEither)
|
|
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
|
|
<> completer (tagCompleter HLS [])
|
|
<> (completer $ versionCompleter Nothing HLS)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader toolVersionTagEither)
|
|
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
|
|
<> completer (tagCompleter Stack [])
|
|
<> (completer $ versionCompleter Nothing Stack)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader isolateParser)
|
|
( short 'b'
|
|
<> long "bindir"
|
|
<> metavar "DIR"
|
|
<> help "directory where to create the tool symlinks (default: newly created system temp dir)"
|
|
<> completer (bashCompleter "directory")
|
|
)
|
|
)
|
|
<*> switch
|
|
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
|
|
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ Footer ]--
|
|
--------------
|
|
|
|
|
|
runFooter :: String
|
|
runFooter = [s|Discussion:
|
|
Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing
|
|
the relevant binaries, then executes a command.
|
|
|
|
Examples:
|
|
# run VSCode with all latest toolchain exposed, installing missing versions if necessary
|
|
ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs
|
|
|
|
# create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH
|
|
ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin
|
|
|
|
# run a specific ghc version
|
|
ghcup run --ghc 8.10.7 -- ghc --version|]
|
|
|
|
|
|
|
|
|
|
---------------------------
|
|
--[ Effect interpreters ]--
|
|
---------------------------
|
|
|
|
|
|
type RunEffects = '[ AlreadyInstalled
|
|
, UnknownArchive
|
|
, ArchiveResult
|
|
, FileDoesNotExistError
|
|
, CopyError
|
|
, NotInstalled
|
|
, DirNotEmpty
|
|
, NoDownload
|
|
, NotInstalled
|
|
, BuildFailed
|
|
, TagNotFound
|
|
, DigestError
|
|
, ContentLengthError
|
|
, GPGError
|
|
, DownloadFailed
|
|
, TarDirDoesNotExist
|
|
, NextVerNotFound
|
|
, NoToolVersionSet
|
|
, FileAlreadyExistsError
|
|
, ProcessError
|
|
, UninstallFailed
|
|
, MergeFileTreeError
|
|
]
|
|
|
|
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
|
|
=> LeanAppState
|
|
-> Excepts RunEffects (ReaderT LeanAppState m) a
|
|
-> m (VEither RunEffects a)
|
|
runLeanRUN leanAppstate =
|
|
-- Don't use runLeanAppState here, which is disabled on windows.
|
|
-- This is the only command on all platforms that doesn't need full appstate.
|
|
flip runReaderT leanAppstate
|
|
. runE
|
|
@RunEffects
|
|
|
|
runRUN :: MonadUnliftIO m
|
|
=> IO AppState
|
|
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
|
|
-> m (VEither RunEffects a)
|
|
runRUN appState action' = do
|
|
s' <- liftIO appState
|
|
flip runReaderT s'
|
|
. runResourceT
|
|
. runE
|
|
@RunEffects
|
|
$ action'
|
|
|
|
|
|
|
|
------------------
|
|
--[ Entrypoint ]--
|
|
------------------
|
|
|
|
|
|
|
|
run :: forall m .
|
|
( MonadFail m
|
|
, MonadMask m
|
|
, MonadCatch m
|
|
, MonadIO m
|
|
, MonadUnliftIO m
|
|
)
|
|
=> RunOptions
|
|
-> IO AppState
|
|
-> LeanAppState
|
|
-> (ReaderT LeanAppState m () -> m ())
|
|
-> m ExitCode
|
|
run RunOptions{..} runAppState leanAppstate runLogger = do
|
|
r <- if not runQuick
|
|
then runRUN runAppState $ do
|
|
toolchain <- liftE resolveToolchainFull
|
|
|
|
-- oh dear
|
|
r <- lift ask
|
|
tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain
|
|
|
|
liftE $ installToolChainFull toolchain tmp
|
|
pure tmp
|
|
else runLeanRUN leanAppstate $ do
|
|
toolchain <- resolveToolchain
|
|
tmp <- lift $ createTmpDir toolchain
|
|
liftE $ installToolChain toolchain tmp
|
|
pure tmp
|
|
case r of
|
|
VRight tmp -> do
|
|
case runCOMMAND of
|
|
[] -> do
|
|
liftIO $ putStr tmp
|
|
pure ExitSuccess
|
|
(cmd:args) -> do
|
|
newEnv <- liftIO $ addToPath tmp
|
|
#ifndef IS_WINDOWS
|
|
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
|
|
pure ExitSuccess
|
|
#else
|
|
r' <- if runMinGWPath
|
|
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
|
|
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
|
|
case r' of
|
|
VRight _ -> pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 28
|
|
#endif
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 27
|
|
|
|
where
|
|
|
|
-- TODO: doesn't work for cross
|
|
resolveToolchainFull :: ( MonadFail m
|
|
, MonadThrow m
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Excepts
|
|
'[ TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet
|
|
] (ResourceT (ReaderT AppState m)) Toolchain
|
|
resolveToolchainFull = do
|
|
ghcVer <- forM runGHCVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) GHC
|
|
pure v
|
|
cabalVer <- forM runCabalVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) Cabal
|
|
pure (_tvVersion v)
|
|
hlsVer <- forM runHLSVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) HLS
|
|
pure (_tvVersion v)
|
|
stackVer <- forM runStackVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) Stack
|
|
pure (_tvVersion v)
|
|
pure Toolchain{..}
|
|
|
|
resolveToolchain = do
|
|
ghcVer <- case runGHCVer of
|
|
Just (GHCVersion v) -> pure $ Just v
|
|
Just (ToolVersion v) -> pure $ Just (mkTVer v)
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
cabalVer <- case runCabalVer of
|
|
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
|
Just (ToolVersion v) -> pure $ Just v
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
hlsVer <- case runHLSVer of
|
|
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
|
Just (ToolVersion v) -> pure $ Just v
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
stackVer <- case runStackVer of
|
|
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
|
Just (ToolVersion v) -> pure $ Just v
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
pure Toolchain{..}
|
|
|
|
installToolChainFull :: ( MonadFail m
|
|
, MonadThrow m
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Toolchain
|
|
-> FilePath
|
|
-> Excepts
|
|
'[ TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet
|
|
, UnknownArchive
|
|
, TarDirDoesNotExist
|
|
, ProcessError
|
|
, NotInstalled
|
|
, NoDownload
|
|
, GPGError
|
|
, DownloadFailed
|
|
, DirNotEmpty
|
|
, DigestError
|
|
, ContentLengthError
|
|
, BuildFailed
|
|
, ArchiveResult
|
|
, AlreadyInstalled
|
|
, FileAlreadyExistsError
|
|
, CopyError
|
|
, UninstallFailed
|
|
, MergeFileTreeError
|
|
] (ResourceT (ReaderT AppState m)) ()
|
|
installToolChainFull Toolchain{..} tmp = do
|
|
case ghcVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' GHC v
|
|
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
|
|
(_tvVersion v)
|
|
GHCupInternal
|
|
False
|
|
[]
|
|
setGHC' v tmp
|
|
_ -> pure ()
|
|
case cabalVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)
|
|
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
|
|
v
|
|
GHCupInternal
|
|
False
|
|
setCabal' v tmp
|
|
_ -> pure ()
|
|
case stackVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)
|
|
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
|
|
v
|
|
GHCupInternal
|
|
False
|
|
setStack' v tmp
|
|
_ -> pure ()
|
|
case hlsVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)
|
|
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
|
|
v
|
|
GHCupInternal
|
|
False
|
|
setHLS' v tmp
|
|
_ -> pure ()
|
|
|
|
installToolChain :: ( MonadFail m
|
|
, MonadThrow m
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Toolchain
|
|
-> FilePath
|
|
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
|
|
installToolChain Toolchain{..} tmp = do
|
|
case ghcVer of
|
|
Just v -> setGHC' v tmp
|
|
_ -> pure ()
|
|
case cabalVer of
|
|
Just v -> setCabal' v tmp
|
|
_ -> pure ()
|
|
case stackVer of
|
|
Just v -> setStack' v tmp
|
|
_ -> pure ()
|
|
case hlsVer of
|
|
Just v -> setHLS' v tmp
|
|
_ -> pure ()
|
|
|
|
setGHC' v tmp = do
|
|
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
|
|
void $ liftE $ setGHC v SetGHCOnly (Just tmp)
|
|
setCabal' v tmp = do
|
|
bin <- liftE $ whereIsTool Cabal (mkTVer v)
|
|
cbin <- liftIO $ canonicalizePath bin
|
|
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
|
|
setStack' v tmp = do
|
|
bin <- liftE $ whereIsTool Stack (mkTVer v)
|
|
cbin <- liftIO $ canonicalizePath bin
|
|
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
|
|
setHLS' v tmp = do
|
|
Dirs {..} <- getDirs
|
|
legacy <- isLegacyHLS v
|
|
if legacy
|
|
then do
|
|
-- TODO: factor this out
|
|
hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v))
|
|
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
|
|
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
|
|
hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
|
|
forM_ hlsBins $ \bin ->
|
|
lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
|
|
liftE $ setHLS v SetHLSOnly (Just tmp)
|
|
else do
|
|
liftE $ setHLS v SetHLS_XYZ (Just tmp)
|
|
liftE $ setHLS v SetHLSOnly (Just tmp)
|
|
|
|
addToPath path = do
|
|
cEnv <- Map.fromList <$> getEnvironment
|
|
let paths = ["PATH", "Path"]
|
|
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
|
newPath = intercalate [searchPathSeparator] (if runAppendPATH then (curPaths ++ [path]) else (path : curPaths))
|
|
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
|
pathVar = if isWindows then "Path" else "PATH"
|
|
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
|
liftIO $ setEnv pathVar newPath
|
|
return envWithNewPath
|
|
|
|
createTmpDir :: ( MonadUnliftIO m
|
|
, MonadCatch m
|
|
, MonadThrow m
|
|
, MonadMask m
|
|
, MonadIO m
|
|
)
|
|
=> Toolchain
|
|
-> ReaderT LeanAppState m FilePath
|
|
createTmpDir toolchain =
|
|
case runBinDir of
|
|
Just bindir -> do
|
|
liftIO $ createDirRecursive' bindir
|
|
liftIO $ canonicalizePath bindir
|
|
Nothing -> do
|
|
d <- predictableTmpDir toolchain
|
|
liftIO $ createDirRecursive' d
|
|
liftIO $ canonicalizePath d
|
|
|
|
predictableTmpDir :: Monad m
|
|
=> Toolchain
|
|
-> ReaderT LeanAppState m FilePath
|
|
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do
|
|
Dirs { tmpDir } <- getDirs
|
|
pure (fromGHCupPath tmpDir </> "ghcup-none")
|
|
predictableTmpDir Toolchain{..} = do
|
|
Dirs { tmpDir } <- getDirs
|
|
pure $ fromGHCupPath tmpDir
|
|
</> ("ghcup-" <> intercalate "_"
|
|
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
|
|
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer
|
|
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer
|
|
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer
|
|
)
|
|
)
|
|
|
|
|
|
|
|
-------------------------
|
|
--[ Other local types ]--
|
|
-------------------------
|
|
|
|
|
|
|
|
data Toolchain = Toolchain
|
|
{ ghcVer :: Maybe GHCTargetVersion
|
|
, cabalVer :: Maybe Version
|
|
, hlsVer :: Maybe Version
|
|
, stackVer :: Maybe Version
|
|
} deriving Show
|