Compare commits

...

14 Commits

21 changed files with 652 additions and 101 deletions

37
.gitlab/ghcup-run.files Normal file
View File

@@ -0,0 +1,37 @@
.
./cabal
./ghc
./ghc-8.10.7
./ghc-pkg
./ghc-pkg-8.10.7
./ghci
./ghci-8.10.7
./haddock
./haddock-8.10.7
./haskell-language-server-8.10.6
./haskell-language-server-8.10.6~1.6.1.0
./haskell-language-server-8.10.7
./haskell-language-server-8.10.7~1.6.1.0
./haskell-language-server-8.6.5
./haskell-language-server-8.6.5~1.6.1.0
./haskell-language-server-8.8.4
./haskell-language-server-8.8.4~1.6.1.0
./haskell-language-server-9.0.1
./haskell-language-server-9.0.1~1.6.1.0
./haskell-language-server-9.0.2
./haskell-language-server-9.0.2~1.6.1.0
./haskell-language-server-9.2.1
./haskell-language-server-9.2.1~1.6.1.0
./haskell-language-server-wrapper
./haskell-language-server-wrapper-1.6.1.0
./hp2ps
./hp2ps-8.10.7
./hpc
./hpc-8.10.7
./hsc2hs
./hsc2hs-8.10.7
./runghc
./runghc-8.10.7
./runhaskell
./runhaskell-8.10.7
./stack

View File

@@ -0,0 +1,81 @@
.
./cabal.exe
./cabal.shim
./ghc-8.10.7.exe
./ghc-8.10.7.shim
./ghc-pkg-8.10.7.exe
./ghc-pkg-8.10.7.shim
./ghc-pkg.exe
./ghc-pkg.shim
./ghc.exe
./ghc.shim
./ghci-8.10.7.exe
./ghci-8.10.7.shim
./ghci.exe
./ghci.shim
./ghcii-8.10.7.sh-8.10.7.exe
./ghcii-8.10.7.sh-8.10.7.shim
./ghcii-8.10.7.sh.exe
./ghcii-8.10.7.sh.shim
./ghcii.sh-8.10.7.exe
./ghcii.sh-8.10.7.shim
./ghcii.sh.exe
./ghcii.sh.shim
./haddock-8.10.7.exe
./haddock-8.10.7.shim
./haddock.exe
./haddock.shim
./haskell-language-server-8.10.6.exe
./haskell-language-server-8.10.6.shim
./haskell-language-server-8.10.6~1.6.1.0.exe
./haskell-language-server-8.10.6~1.6.1.0.shim
./haskell-language-server-8.10.7.exe
./haskell-language-server-8.10.7.shim
./haskell-language-server-8.10.7~1.6.1.0.exe
./haskell-language-server-8.10.7~1.6.1.0.shim
./haskell-language-server-8.6.5.exe
./haskell-language-server-8.6.5.shim
./haskell-language-server-8.6.5~1.6.1.0.exe
./haskell-language-server-8.6.5~1.6.1.0.shim
./haskell-language-server-8.8.4.exe
./haskell-language-server-8.8.4.shim
./haskell-language-server-8.8.4~1.6.1.0.exe
./haskell-language-server-8.8.4~1.6.1.0.shim
./haskell-language-server-9.0.1.exe
./haskell-language-server-9.0.1.shim
./haskell-language-server-9.0.1~1.6.1.0.exe
./haskell-language-server-9.0.1~1.6.1.0.shim
./haskell-language-server-9.0.2.exe
./haskell-language-server-9.0.2.shim
./haskell-language-server-9.0.2~1.6.1.0.exe
./haskell-language-server-9.0.2~1.6.1.0.shim
./haskell-language-server-9.2.1.exe
./haskell-language-server-9.2.1.shim
./haskell-language-server-9.2.1~1.6.1.0.exe
./haskell-language-server-9.2.1~1.6.1.0.shim
./haskell-language-server-wrapper-1.6.1.0.exe
./haskell-language-server-wrapper-1.6.1.0.shim
./haskell-language-server-wrapper.exe
./haskell-language-server-wrapper.shim
./hp2ps-8.10.7.exe
./hp2ps-8.10.7.shim
./hp2ps.exe
./hp2ps.shim
./hpc-8.10.7.exe
./hpc-8.10.7.shim
./hpc.exe
./hpc.shim
./hsc2hs-8.10.7.exe
./hsc2hs-8.10.7.shim
./hsc2hs.exe
./hsc2hs.shim
./runghc-8.10.7.exe
./runghc-8.10.7.shim
./runghc.exe
./runghc.shim
./runhaskell-8.10.7.exe
./runhaskell-8.10.7.shim
./runhaskell.exe
./runhaskell.shim
./stack.exe
./stack.shim

View File

@@ -97,6 +97,7 @@ eghcup --numeric-version
eghcup install ghc ${GHC_VERSION} eghcup install ghc ${GHC_VERSION}
[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ] [ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
[ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ]
eghcup set ghc ${GHC_VERSION} eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION} eghcup install cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
@@ -104,6 +105,22 @@ eghcup unset cabal
"$GHCUP_BIN"/cabal --version && exit || echo yes "$GHCUP_BIN"/cabal --version && exit || echo yes
eghcup set cabal ${CABAL_VERSION} eghcup set cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
[ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ]
if [ "${OS}" != "FREEBSD" ] ; then
if [ "${ARCH}" = "64" ] ; then
eghcup run --ghc 8.10.7 --cabal 3.4.1.0 --hls 1.6.1.0 --stack 2.7.3 --install --bindir "$(pwd)/.bin"
if [ "${OS}" == "WINDOWS" ] ; then
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files.windows" | sort)
else
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort)
fi
actual=$(cd ".bin" && find . | sort)
[ "${actual}" = "${expected}" ]
unset actual expected
rm -rf .bin
fi
fi
cabal --version cabal --version
@@ -133,7 +150,7 @@ else
eghcup --offline install ghc 8.10.3 eghcup --offline install ghc 8.10.3
if [ "${ARCH}" = "64" ] ; then if [ "${ARCH}" = "64" ] ; then
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort) expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort)
actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort) actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort)
[ "${actual}" = "${expected}" ] [ "${actual}" = "${expected}" ]
unset actual expected unset actual expected
fi fi
@@ -141,7 +158,7 @@ else
eghcup prefetch ghc 8.10.3 eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3 eghcup --offline install ghc 8.10.3
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort) expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort)
actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort) actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort)
[ "${actual}" = "${expected}" ] [ "${actual}" = "${expected}" ]
unset actual expected unset actual expected
else else
@@ -182,6 +199,8 @@ else
fi fi
fi fi
# check that lazy loading works for 'whereis' # check that lazy loading works for 'whereis'
cp "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak" cp "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak"
echo '**' > "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" echo '**' > "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"

View File

@@ -1,5 +1,17 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.17.5 -- ????-??-??
* Support installation of dynamic HLS bindists wrt [HLS #2675](https://github.com/haskell/haskell-language-server/pull/2675) and [#237](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/237)
* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/311)
* Add support for quilt-style patches wrt [#230](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/230), by James Hobson
* Fix redundant upgrade warnings in `ghcup upgrade`
* Fix `ghcup whereis ghc` for non-standard versions wrt [#289](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/289)
* Don't print logs to stdout, but stderr
* Allow unpacking legacy lzma archives wrt [#307](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/307)
* Allow to disable self-upgrade functionality wrt [#305](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/305)
* Fix `ghcup install ghc --set` when ghc is already installed wrt [#291](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/291)
## 0.1.17.4 -- 2021-11-13 ## 0.1.17.4 -- 2021-11-13
* add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278) * add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)

View File

@@ -493,9 +493,9 @@ set' _ (_, ListResult {..}) = do
run (do run (do
case lTool of case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> () GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
Cabal -> liftE $ setCabal lVer $> () Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer SetHLSOnly $> () HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
Stack -> liftE $ setStack lVer $> () Stack -> liftE $ setStack lVer $> ()
GHCup -> pure () GHCup -> pure ()
) )

View File

@@ -24,6 +24,7 @@ module GHCup.OptParse (
, module GHCup.OptParse.DInfo , module GHCup.OptParse.DInfo
, module GHCup.OptParse.Nuke , module GHCup.OptParse.Nuke
, module GHCup.OptParse.ToolRequirements , module GHCup.OptParse.ToolRequirements
, module GHCup.OptParse.Run
, module GHCup.OptParse , module GHCup.OptParse
) where ) where
@@ -33,6 +34,7 @@ import GHCup.OptParse.Install
import GHCup.OptParse.Set import GHCup.OptParse.Set
import GHCup.OptParse.UnSet import GHCup.OptParse.UnSet
import GHCup.OptParse.Rm import GHCup.OptParse.Rm
import GHCup.OptParse.Run
import GHCup.OptParse.Compile import GHCup.OptParse.Compile
import GHCup.OptParse.Config import GHCup.OptParse.Config
import GHCup.OptParse.Whereis import GHCup.OptParse.Whereis
@@ -104,6 +106,7 @@ data Command
#endif #endif
| Prefetch PrefetchCommand | Prefetch PrefetchCommand
| GC GCOptions | GC GCOptions
| Run RunOptions
@@ -263,6 +266,16 @@ com =
(progDesc "Garbage collection" (progDesc "Garbage collection"
<> footerDoc ( Just $ text gcFooter )) <> footerDoc ( Just $ text gcFooter ))
) )
<> command
"run"
(Run
<$>
info
(runOpts <**> helper)
(progDesc "Run a command with the given tool in PATH"
<> footerDoc ( Just $ text runFooter )
)
)
<> commandGroup "Main commands:" <> commandGroup "Main commands:"
) )
<|> subparser <|> subparser

View File

@@ -466,7 +466,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)
) )
>>= \case >>= \case
@@ -517,7 +517,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)
) )
>>= \case >>= \case

View File

@@ -17,7 +17,6 @@ import GHCup.OptParse.Common
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
@@ -353,7 +352,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
isolateDir isolateDir
forceInstall forceInstall
) )
$ when instSet $ void $ setGHC v SetGHCOnly $ when instSet $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
@@ -364,7 +363,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
isolateDir isolateDir
forceInstall forceInstall
) )
$ when instSet $ void $ setGHC v SetGHCOnly $ when instSet $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
) )
>>= \case >>= \case

View File

@@ -0,0 +1,348 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.OptParse.Run where
import GHCup
import GHCup.Utils
import GHCup.Utils.Prelude
import GHCup.Utils.File
import GHCup.OptParse.Common
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics ( getDirs )
import GHCup.Utils.Logger
import GHCup.Utils.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.Directory
import System.FilePath
import System.Environment
import System.IO.Temp
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
---------------
--[ Options ]--
---------------
data RunOptions = RunOptions
{ runAppendPATH :: Bool
, runInstTool' :: Bool
, runGHCVer :: Maybe ToolVersion
, runCabalVer :: Maybe ToolVersion
, runHLSVer :: Maybe ToolVersion
, runStackVer :: Maybe ToolVersion
, runBinDir :: Maybe FilePath
, 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")
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version")
)
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version")
)
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version")
)
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version")
)
<*> optional
(option
(eitherReader isolateParser)
( short 'b'
<> long "bindir"
<> metavar "DIR"
<> help "directory where to create the tool symlinks (default: newly created system temp dir)"
)
)
<*> 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
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
]
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
=> (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither RunEffects a)
runRUN runAppState =
runAppState
. runResourceT
. runE
@RunEffects
------------------
--[ Entrypoint ]--
------------------
run :: forall m.
( MonadFail m
, MonadMask m
, MonadCatch m
, MonadIO m
, MonadUnliftIO m
)
=> RunOptions
-> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
-> LeanAppState
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
run RunOptions{..} runAppState leanAppstate runLogger = do
tmp <- case runBinDir of
Just bdir -> do
liftIO $ createDirRecursive' bdir
liftIO $ canonicalizePath bdir
Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup")
r <- do
addToolsToDir tmp
case r of
VRight _ -> 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' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec 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
isToolTag :: ToolVersion -> Bool
isToolTag (ToolTag _) = True
isToolTag _ = False
-- TODO: doesn't work for cross
addToolsToDir tmp
| or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
forM_ runGHCVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) GHC
installTool GHC v
setTool GHC v tmp
forM_ runCabalVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Cabal
installTool Cabal v
setTool Cabal v tmp
forM_ runHLSVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) HLS
installTool HLS v
setTool HLS v tmp
forM_ runStackVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Stack
installTool Stack v
setTool Stack v tmp
| otherwise = runLeanRUN leanAppstate $ do
case runGHCVer of
Just (ToolVersion v) ->
setTool GHC v tmp
Nothing -> pure ()
_ -> fail "Internal error"
case runCabalVer of
Just (ToolVersion v) ->
setTool Cabal v tmp
Nothing -> pure ()
_ -> fail "Internal error"
case runHLSVer of
Just (ToolVersion v) ->
setTool HLS v tmp
Nothing -> pure ()
_ -> fail "Internal error"
case runStackVer of
Just (ToolVersion v) ->
setTool Stack v tmp
Nothing -> pure ()
_ -> fail "Internal error"
installTool tool v = do
isInstalled <- checkIfToolInstalled' tool v
case tool of
GHC -> do
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v)
Nothing
False
Cabal -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
(_tvVersion v)
Nothing
False
Stack -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
(_tvVersion v)
Nothing
False
HLS -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
(_tvVersion v)
Nothing
False
GHCup -> pure ()
setTool tool v tmp =
case tool of
GHC -> do
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
void $ liftE $ setGHC v SetGHCOnly (Just tmp)
Cabal -> do
bin <- liftE $ whereIsTool Cabal v
cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
Stack -> do
bin <- liftE $ whereIsTool Stack v
cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
HLS -> do
Dirs {..} <- getDirs
let v' = _tvVersion v
legacy <- isLegacyHLS v'
if legacy
then do
-- TODO: factor this out
(Just hlsWrapper) <- hlsWrapperBinary 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 (_tvVersion v) SetHLSOnly (Just tmp)
else do
liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)
liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
GHCup -> pure ()
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

View File

@@ -271,10 +271,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setGHC' SetOptions{ sToolVer } = setGHC' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v) (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)
_ -> runSetGHC runAppState (do _ -> runSetGHC runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly liftE $ setGHC v SetGHCOnly Nothing
) )
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
@@ -311,10 +311,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setHLS' SetOptions{ sToolVer } = setHLS' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly >> pure v) (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v)
_ -> runSetHLS runAppState (do _ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v) SetHLSOnly liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
pure v pure v
) )
>>= \case >>= \case

View File

@@ -313,6 +313,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nuke -> nuke appState runLogger Nuke -> nuke appState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand runAppState leanAppstate runLogger
case res of case res of
ExitSuccess -> pure () ExitSuccess -> pure ()

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.17.4 version: 0.1.17.5
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020
@@ -65,6 +65,7 @@ library
GHCup.Requirements GHCup.Requirements
GHCup.Types GHCup.Types
GHCup.Types.JSON GHCup.Types.JSON
GHCup.Types.JSON.Utils
GHCup.Types.Optics GHCup.Types.Optics
GHCup.Utils GHCup.Utils
GHCup.Utils.Dirs GHCup.Utils.Dirs
@@ -199,6 +200,7 @@ executable ghcup
GHCup.OptParse.Nuke GHCup.OptParse.Nuke
GHCup.OptParse.Prefetch GHCup.OptParse.Prefetch
GHCup.OptParse.Rm GHCup.OptParse.Rm
GHCup.OptParse.Run
GHCup.OptParse.Set GHCup.OptParse.Set
GHCup.OptParse.ToolRequirements GHCup.OptParse.ToolRequirements
GHCup.OptParse.UnSet GHCup.OptParse.UnSet
@@ -242,6 +244,7 @@ executable ghcup
, resourcet ^>=1.2.2 , resourcet ^>=1.2.2
, safe ^>=0.3.18 , safe ^>=0.3.18
, safe-exceptions ^>=0.1 , safe-exceptions ^>=0.1
, temporary ^>=1.3
, template-haskell >=2.7 && <2.18 , template-haskell >=2.7 && <2.18
, text ^>=1.2.4.0 , text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2 , uri-bytestring ^>=0.3.2.2
@@ -264,6 +267,9 @@ executable ghcup
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
else
build-depends:
, unix ^>=2.7
if flag(no-exe) if flag(no-exe)
buildable: False buildable: False

View File

@@ -616,15 +616,15 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
if legacy if legacy
then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall
else liftE $ installHLSUnpacked workdir isoDir ver else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir isoDir ver
Nothing -> do Nothing -> do
if legacy if legacy
then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall
else do else do
inst <- ghcupHLSDir ver inst <- ghcupHLSDir ver
liftE $ installHLSUnpacked workdir inst ver liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver
liftE $ setHLS ver SetHLS_XYZ liftE $ setHLS ver SetHLS_XYZ Nothing
liftE $ installHLSPostInst isoFilepath ver liftE $ installHLSPostInst isoFilepath ver
@@ -707,7 +707,7 @@ installHLSPostInst isoFilepath ver =
-- create symlink if this is the latest version in a regular install -- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly Nothing
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@ -- | Installs hls binaries @haskell-language-server-\<ghcver\>@
@@ -1092,22 +1092,29 @@ setGHC :: ( MonadReader env m
) )
=> GHCTargetVersion => GHCTargetVersion
-> SetGHC -> SetGHC
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m GHCTargetVersion -> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do setGHC ver sghc mBinDir = do
let verS = T.unpack $ prettyVer (_tvVersion ver) let verS = T.unpack $ prettyVer (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination -- symlink destination
Dirs {..} <- lift getDirs binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup) -- with old ghcup)
case sghc of when (isNothing mBinDir) $
SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) case sghc of
SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver
SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
@@ -1129,13 +1136,14 @@ setGHC ver sghc = do
bindir <- ghcInternalBinDir ver bindir <- ghcInternalBinDir ver
let fullF = binDir </> targetFile <> exeExt let fullF = binDir </> targetFile <> exeExt
fileWithExt = bindir </> file <> exeExt fileWithExt = bindir </> file <> exeExt
destL <- binarySymLinkDestination fileWithExt destL <- binarySymLinkDestination binDir fileWithExt
lift $ createLink destL fullF lift $ createLink destL fullF
-- create symlink for share dir when (isNothing mBinDir) $ do
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS -- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
pure ver pure ver
@@ -1241,19 +1249,26 @@ setHLS :: ( MonadReader env m
) )
=> Version => Version
-> SetHLS -- Nothing for legacy -> SetHLS -- Nothing for legacy
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setHLS ver shls = do setHLS ver shls mBinDir = do
whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
-- symlink destination -- symlink destination
Dirs {..} <- lift getDirs binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
-- first delete the old symlinks -- first delete the old symlinks
case shls of when (isNothing mBinDir) $
-- not for legacy case shls of
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver -- not for legacy
-- legacy and new SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
SetHLSOnly -> liftE rmPlainHLS -- legacy and new
SetHLSOnly -> liftE rmPlainHLS
case shls of case shls of
-- not for legacy -- not for legacy
@@ -1262,7 +1277,7 @@ setHLS ver shls = do
forM_ bins $ \f -> do forM_ bins $ \f -> do
let fname = takeFileName f let fname = takeFileName f
destL <- binarySymLinkDestination f destL <- binarySymLinkDestination binDir f
let target = if "haskell-language-server-wrapper" `isPrefixOf` fname let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
@@ -1285,7 +1300,8 @@ setHLS ver shls = do
lift $ createLink destL wrapper lift $ createLink destL wrapper
lift warnAboutHlsCompatibility when (isNothing mBinDir) $
lift warnAboutHlsCompatibility
unsetHLS :: ( MonadMask m unsetHLS :: ( MonadMask m
@@ -1774,7 +1790,7 @@ rmGHCVer ver = do
$ fmap Just $ fmap Just
$ getMajorMinorV (_tvVersion ver) $ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
@@ -1841,7 +1857,7 @@ rmHLSVer ver = do
-- set latest hls -- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver SetHLSOnly Just latestver -> setHLS latestver SetHLSOnly Nothing
Nothing -> pure () Nothing -> pure ()
@@ -2275,7 +2291,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
Nothing -> do Nothing -> do
reThrowAll GHCupSetError $ postGHCInstall installVer reThrowAll GHCupSetError $ postGHCInstall installVer
-- restore -- restore
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing
_ -> pure () _ -> pure ()
@@ -2669,7 +2685,7 @@ postGHCInstall :: ( MonadReader env m
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
postGHCInstall ver@GHCTargetVersion {..} = do postGHCInstall ver@GHCTargetVersion {..} = do
void $ liftE $ setGHC ver SetGHC_XYZ void $ liftE $ setGHC ver SetGHC_XYZ Nothing
-- Create ghc-x.y symlinks. This may not be the current -- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless. -- version, create it regardless.
@@ -2678,7 +2694,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
$ fmap Just $ fmap Just
$ getMajorMinorV _tvVersion $ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)
-- | Reports the binary location of a given tool: -- | Reports the binary location of a given tool:
@@ -2739,13 +2755,21 @@ checkIfToolInstalled :: ( MonadIO m
Tool -> Tool ->
Version -> Version ->
m Bool m Bool
checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver)
checkIfToolInstalled tool ver = checkIfToolInstalled' :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadCatch m) =>
Tool ->
GHCTargetVersion ->
m Bool
checkIfToolInstalled' tool ver =
case tool of case tool of
Cabal -> cabalInstalled ver Cabal -> cabalInstalled (_tvVersion ver)
HLS -> hlsInstalled ver HLS -> hlsInstalled (_tvVersion ver)
Stack -> stackInstalled ver Stack -> stackInstalled (_tvVersion ver)
GHC -> ghcInstalled $ mkTVer ver GHC -> ghcInstalled ver
_ -> pure False _ -> pure False
throwIfFileAlreadyExists :: ( MonadIO m ) => throwIfFileAlreadyExists :: ( MonadIO m ) =>

View File

@@ -6,6 +6,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-| {-|
@@ -30,12 +31,15 @@ import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) ) import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) import GHC.IO.Exception ( ExitCode )
import Optics ( makeLenses )
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>))
import URI.ByteString import URI.ByteString
#if defined(BRICK) #if defined(BRICK)
import Graphics.Vty ( Key(..) ) import Graphics.Vty ( Key(..) )
#endif #endif
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
@@ -600,3 +604,27 @@ data LoggerConfig = LoggerConfig
instance NFData LoggerConfig where instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors) rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)
data ProcessError = NonZeroExit Int FilePath [String]
| PTerminated FilePath [String]
| PStopped FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString
, _stdErr :: BL.ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess

View File

@@ -22,10 +22,8 @@ Portability : portable
module GHCup.Types.JSON where module GHCup.Types.JSON where
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON.Utils
import GHCup.Utils.MegaParsec import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.Logger () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.
-- This is due to the boot file.
import Control.Applicative ( (<|>) ) import Control.Applicative ( (<|>) )
import Data.Aeson hiding (Key) import Data.Aeson hiding (Key)
@@ -40,6 +38,7 @@ import Text.Casing
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding.Error as E
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC import qualified Text.Megaparsec.Char as MPC
@@ -78,7 +77,7 @@ instance FromJSON Tag where
x -> pure (UnknownTag x) x -> pure (UnknownTag x)
instance ToJSON URI where instance ToJSON URI where
toJSON = toJSON . decUTF8Safe . serializeURIRef' toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
instance FromJSON URI where instance FromJSON URI where
parseJSON = withText "URL" $ \t -> parseJSON = withText "URL" $ \t ->

View File

@@ -0,0 +1,17 @@
{-|
Module : GHCup.Types.JSON.Utils
Description : Utils for TH splices
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Types.JSON.Utils where
import qualified Data.Text as T
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'

View File

@@ -3,7 +3,6 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
@@ -127,15 +126,13 @@ import qualified Data.List.NonEmpty as NE
-- | Create a relative symlink destination for the binary directory, -- | Create a relative symlink destination for the binary directory,
-- given a target toolpath. -- given a target toolpath.
binarySymLinkDestination :: ( MonadReader env m binarySymLinkDestination :: ( MonadThrow m
, HasDirs env
, MonadThrow m
, MonadIO m , MonadIO m
) )
=> FilePath -- ^ the full toolpath => FilePath -- ^ binary dir
-> FilePath -- ^ the full toolpath
-> m FilePath -> m FilePath
binarySymLinkDestination toolPath = do binarySymLinkDestination binDir toolPath = do
Dirs {..} <- getDirs
toolPath' <- liftIO $ canonicalizePath toolPath toolPath' <- liftIO $ canonicalizePath toolPath
binDir' <- liftIO $ canonicalizePath binDir binDir' <- liftIO $ canonicalizePath binDir
pure (relativeSymlink binDir' toolPath') pure (relativeSymlink binDir' toolPath')
@@ -230,7 +227,7 @@ rmMinorHLSSymlinks ver = do
hlsBins <- hlsAllBinaries ver hlsBins <- hlsAllBinaries ver
forM_ hlsBins $ \f -> do forM_ hlsBins $ \f -> do
let fullF = binDir </> f <> exeExt let fullF = binDir </> f
lift $ logDebug ("rm -f " <> T.pack fullF) lift $ logDebug ("rm -f " <> T.pack fullF)
-- on unix, this may be either a file (legacy) or a symlink -- on unix, this may be either a file (legacy) or a symlink
-- on windows, this is always a file... hence 'rmFile' -- on windows, this is always a file... hence 'rmFile'

View File

@@ -1,11 +1,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Utils.File.Common where module GHCup.Utils.File.Common (
module GHCup.Utils.File.Common
, ProcessError(..)
, CapturedProcess(..)
) where
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types(ProcessError(..), CapturedProcess(..))
import Control.Monad.Reader import Control.Monad.Reader
import Data.Maybe import Data.Maybe
@@ -24,33 +27,6 @@ import qualified Text.Megaparsec as MP
data ProcessError = NonZeroExit Int FilePath [String]
| PTerminated FilePath [String]
| PStopped FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString
, _stdErr :: BL.ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
-- | Search for a file in the search paths. -- | Search for a file in the search paths.
-- --
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`. -- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.

View File

@@ -1,5 +1,4 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@@ -18,7 +17,7 @@ module GHCup.Utils.Logger where
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.File.Common import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
import Control.Exception.Safe import Control.Exception.Safe

View File

@@ -1,7 +1,5 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Utils.Logger where module GHCup.Utils.Logger where

View File

@@ -30,7 +30,7 @@ where
import GHCup.Types import GHCup.Types
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Logger import {-# SOURCE #-} GHCup.Utils.Logger (logWarn)
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
import GHCup.Utils.Prelude.Windows import GHCup.Utils.Prelude.Windows
#else #else
@@ -308,11 +308,6 @@ intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
pvpToVersion :: MonadThrow m => PVP -> Text -> m Version pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
pvpToVersion pvp_ rest = pvpToVersion pvp_ rest =
either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_ either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_
@@ -477,7 +472,9 @@ recyclePathForcibly fp
let dest = tmp </> takeFileName fp let dest = tmp </> takeFileName fp
liftIO (moveFile fp dest) liftIO (moveFile fp dest)
`catch` `catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e) (\e -> if | isDoesNotExistError e -> pure ()
| isPermissionError e {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
| otherwise -> throwIO e)
`finally` `finally`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removePathForcibly fp | otherwise = liftIO $ removePathForcibly fp