Compare commits
14 Commits
hls-dynami
...
issue-137
| Author | SHA1 | Date | |
|---|---|---|---|
|
c859b3ee2b
|
|||
|
8a16b0de7c
|
|||
|
9faf17634b
|
|||
|
66a62c170c
|
|||
|
5186d959bc
|
|||
|
09a8a0bda0
|
|||
|
191f49adfc
|
|||
|
c72841ca58
|
|||
|
63350dab71
|
|||
|
d110d20879
|
|||
|
b4e58478c3
|
|||
|
12d2acd7fd
|
|||
|
6073ebe476
|
|||
|
5c026591cb
|
37
.gitlab/ghcup-run.files
Normal file
37
.gitlab/ghcup-run.files
Normal 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
|
||||||
81
.gitlab/ghcup-run.files.windows
Normal file
81
.gitlab/ghcup-run.files.windows
Normal 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
|
||||||
@@ -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"
|
||||||
|
|||||||
12
CHANGELOG.md
12
CHANGELOG.md
@@ -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)
|
||||||
|
|||||||
@@ -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 ()
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
348
app/ghcup/GHCup/OptParse/Run.hs
Normal file
348
app/ghcup/GHCup/OptParse/Run.hs
Normal 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
|
||||||
@@ -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
|
||||||
|
|||||||
@@ -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 ()
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
90
lib/GHCup.hs
90
lib/GHCup.hs
@@ -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 ) =>
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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 ->
|
||||||
|
|||||||
17
lib/GHCup/Types/JSON/Utils.hs
Normal file
17
lib/GHCup/Types/JSON/Utils.hs
Normal 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'
|
||||||
@@ -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'
|
||||||
|
|||||||
@@ -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`.
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
Reference in New Issue
Block a user