Compare commits

..

1 Commits

Author SHA1 Message Date
2c3ebe706d Windows support 2021-05-21 17:10:22 +02:00
38 changed files with 16781 additions and 15565 deletions

View File

@@ -20,7 +20,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.alpine:64bit:
image: "alpine:3.12"
@@ -29,7 +28,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.alpine:32bit:
image: "i386/alpine:3.12"
@@ -38,7 +36,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "32"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.linux:armv7:
image: "arm32v7/fedora"
@@ -47,7 +44,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "ARM"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.linux:aarch64:
image: "arm64v8/fedora"
@@ -56,7 +52,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "ARM64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.darwin:
tags:
@@ -64,15 +59,6 @@ variables:
variables:
OS: "DARWIN"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.darwin:aarch64:
tags:
- aarch64-darwin-m1
variables:
OS: "DARWIN"
ARCH: "ARM64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.freebsd:
tags:
@@ -80,25 +66,22 @@ variables:
variables:
OS: "FREEBSD"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.windows:
tags:
- new-x86_64-windows
variables:
OS: "WINDOWS"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.root_cleanup:
after_script:
- bash ./.gitlab/after_script.sh
- BUILD_DIR=$CI_PROJECT_DIR
- echo "Cleaning $BUILD_DIR"
- cd $HOME
- test -n "$BUILD_DIR"
- shopt -s extglob
- rm -Rf "$BUILD_DIR"/!(out)
- exit 0
.test_ghcup_version:
script:
- bash ./.gitlab/script/ghcup_version.sh
- ./.gitlab/script/ghcup_version.sh
variables:
JSON_VERSION: "0.0.5"
JSON_VERSION: "0.0.4"
artifacts:
expire_in: 2 week
paths:
@@ -141,14 +124,6 @@ variables:
before_script:
- ./.gitlab/before_script/darwin/install_deps.sh
.test_ghcup_version:darwin:aarch64:
extends:
- .test_ghcup_version
- .darwin:aarch64
- .root_cleanup
before_script:
- ./.gitlab/before_script/darwin/install_deps.sh
.test_ghcup_version:freebsd:
extends:
- .test_ghcup_version
@@ -157,18 +132,9 @@ variables:
before_script:
- ./.gitlab/before_script/freebsd/install_deps.sh
.test_ghcup_version:windows:
extends:
- .test_ghcup_version
- .windows
- .root_cleanup
before_script:
- set CABAL_DIR="$CI_PROJECT_DIR/cabal"
- bash ./.gitlab/before_script/windows/install_deps.sh
.release_ghcup:
script:
- bash ./.gitlab/script/ghcup_release.sh
- ./.gitlab/script/ghcup_release.sh
artifacts:
expire_in: 2 week
paths:
@@ -176,7 +142,7 @@ variables:
only:
- tags
variables:
JSON_VERSION: "0.0.5"
JSON_VERSION: "0.0.4"
######## stack test ########
@@ -199,7 +165,7 @@ test:linux:bootstrap_script:
script:
- ./.gitlab/script/ghcup_bootstrap.sh
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
extends:
- .debian
@@ -211,7 +177,7 @@ test:linux:recommended:
stage: test
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
@@ -219,7 +185,7 @@ test:linux:latest:
stage: test
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "9.0.1"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
@@ -229,7 +195,7 @@ test:linux:recommended:32bit:
stage: test
extends: .test_ghcup_version:linux32
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.2.0.0"
needs: []
@@ -267,15 +233,7 @@ test:mac:latest:
stage: test
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "9.0.1"
CABAL_VERSION: "3.4.0.0"
needs: []
test:mac:recommended:aarch64:
stage: test
extends: .test_ghcup_version:darwin:aarch64
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
@@ -292,16 +250,17 @@ test:freebsd:recommended:
when: manual
needs: []
######## windows test ########
test:windows:recommended:
test:freebsd:latest:
stage: test
extends: .test_ghcup_version:windows
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true # freebsd runners are unreliable
when: manual
needs: []
######## linux release ########
release:linux:64bit:
@@ -314,7 +273,7 @@ release:linux:64bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "x86_64-linux-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
@@ -328,7 +287,7 @@ release:linux:32bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "i386-linux-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.2.0.0"
release:linux:armv7:
@@ -370,22 +329,7 @@ release:darwin:
- ./.gitlab/before_script/darwin/install_deps.sh
variables:
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
MACOSX_DEPLOYMENT_TARGET: "10.7"
release:darwin:aarch64:
stage: release
needs: ["test:mac:recommended:aarch64"]
extends:
- .darwin:aarch64
- .release_ghcup
- .root_cleanup
before_script:
- ./.gitlab/before_script/darwin/install_deps.sh
variables:
ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
MACOSX_DEPLOYMENT_TARGET: "10.7"
@@ -394,7 +338,7 @@ release:darwin:aarch64:
release:freebsd:
stage: release
needs: ["test:freebsd:recommended"]
needs: ["test:freebsd:recommended", "test:freebsd:latest"]
extends:
- .freebsd
- .release_ghcup
@@ -403,24 +347,9 @@ release:freebsd:
- ./.gitlab/before_script/freebsd/install_deps.sh
variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
######## windows release ########
release:windows:
stage: release
needs: ["test:windows:recommended"]
extends:
- .windows
- .release_ghcup
- .root_cleanup
before_script:
- bash ./.gitlab/before_script/windows/install_deps.sh
variables:
ARTIFACT: "x86_64-mingw64-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
######## hlint ########
@@ -433,7 +362,7 @@ hlint:
script:
- ./.gitlab/script/hlint.sh
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
JSON_VERSION: "0.0.4"
allow_failure: true

View File

@@ -1,15 +0,0 @@
#!/bin/sh
set -eux
BUILD_DIR=$CI_PROJECT_DIR
echo "Cleaning $BUILD_DIR"
cd $HOME
test -n "$BUILD_DIR"
shopt -s extglob
rm -Rf "$BUILD_DIR"/!(out)
if [ "${OS}" = "WINDOWS" ] ; then
rm -Rf /c/ghcup
fi
exit 0

View File

@@ -6,34 +6,12 @@ set -eux
mkdir -p "${TMPDIR}"
if [ $ARCH = 'ARM64' ] ; then
curl -L -O https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-aarch64-apple-darwin.tar.xz
tar -xf ghc-*.tar.*
cd ghc-*
./configure --prefix="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/ghc/8.10.5
make install
for i in "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/ghc/8.10.5/bin/*-8.10.5 ; do
ln -s "${i}" "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/${i##*/}
done
for x in "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/*-8.10.5 ; do
ln -s ${x##*/} ${x%-8.10.5}
done
unset x i
cd ..
rm -rf ghc-8.10.5 ghc-*.tar.*
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./ghcup-bin
chmod +x ghcup-bin
curl -L -O https://github.com/haskell/cabal/files/6617482/cabal-install-3.5-arm64-darwin-11.4-bootstrapped.tar.gz
tar xf cabal-install-*
mv cabal "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/cabal
rm -rf cabal-install
else
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./ghcup-bin
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
fi
./ghcup-bin upgrade -i -f
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
exit 0

View File

@@ -1,21 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
mkdir -p "${TMPDIR}" "${CABAL_DIR}"
mkdir -p "$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin"
CI_PROJECT_DIR=$(pwd)
curl -o ghcup.exe https://downloads.haskell.org/~ghcup/tmp/x86_64-mingw64-ghcup-9.exe
chmod +x ghcup.exe
./ghcup.exe install ${GHC_VERSION}
./ghcup.exe set ${GHC_VERSION}
./ghcup.exe install-cabal ${CABAL_VERSION}
rm ./ghcup.exe
exit 0

View File

@@ -1,9 +1,3 @@
if [ "${OS}" = "WINDOWS" ] ; then
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export PATH="$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp"
else
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export PATH="$CI_PROJECT_DIR/.ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp"
fi
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export PATH="$CI_PROJECT_DIR/.ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp"

View File

@@ -7,7 +7,7 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
eghcup() {

View File

@@ -7,7 +7,7 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
git describe
@@ -29,9 +29,7 @@ if [ "${OS}" = "LINUX" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" --constraint="zip +disable-zstd" -ftui
elif [ "${OS}" = "WINDOWS" ] ; then
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static"
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" -ftui
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
fi

View File

@@ -6,18 +6,12 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
CI_PROJECT_DIR=$(pwd)
ecabal() {
cabal "$@"
cabal --store-dir="$CI_PROJECT_DIR"/.store "$@"
}
eghcup() {
if [ "${OS}" = "WINDOWS" ] ; then
ghcup -v -c -s file:/$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
else
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
fi
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
@@ -34,42 +28,30 @@ ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -ftui
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd" ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
elif [ "${OS}" = "WINDOWS" ] ; then
ecabal build -w ghc-${GHC_VERSION}
ecabal test -w ghc-${GHC_VERSION} ghcup-test
ecabal haddock -w ghc-${GHC_VERSION}
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
ecabal haddock -w ghc-${GHC_VERSION} -ftar
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
### cleanup
if [ "${OS}" = "WINDOWS" ] ; then
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing
@@ -93,11 +75,9 @@ eghcup list -t cabal
ghc_ver=$(ghc --numeric-version)
ghc --version
ghc-${ghc_ver} --version
if [ "${OS}" != "WINDOWS" ] ; then
ghci --version
ghci-${ghc_ver} --version
fi
ghci --version
ghc-$(ghc --numeric-version) --version
ghci-$(ghc --numeric-version) --version
# test installing new ghc doesn't mess with currently set GHC
@@ -109,11 +89,7 @@ else # test wget a bit
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup set 8.10.3
eghcup list
which ghc
eghcup set 8.10.3
eghcup list
which ghc
[ "$(ghc --numeric-version)" = "8.10.3" ]
eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]

View File

@@ -2,11 +2,9 @@
## 0.1.15 -- ????-??-??
* Add windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130)
* Add date to GHC bindist names created by ghcup
* Warn when /tmp doesn't have 5GB or more of disk space
* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
* Allow to set custom ghc version when running 'ghcup compile ghc' wrt [#136](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/136)
* Add stack support
## 0.1.14.2 -- 2021-05-12

View File

@@ -69,15 +69,13 @@ tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only check certain tarballs (format: <tool>-<version>)"
where
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
def = TarballFilter Nothing (makeRegex ("" :: String))
readm = do
s <- str
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
_ -> fail "invalid tool"
low = fmap toLower
@@ -107,21 +105,26 @@ main :: IO ()
main = do
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
ValidateYAML vopts -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validate
ValidateTarballs vopts tarballFilter -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit (validateTarballs tarballFilter)
pure ()
where
withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
(GHCupInfo _ av) <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith

View File

@@ -11,7 +11,6 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
@@ -23,7 +22,6 @@ import qualified Codec.Archive.Tar as Tar
#else
import Codec.Archive
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
@@ -68,9 +66,8 @@ addError = do
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validate dls _ = do
validate dls = do
ref <- liftIO $ newIORef 0
-- verify binary downloads --
@@ -184,7 +181,7 @@ validate dls _ = do
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
{ tfTool :: Maybe Tool
, tfVersion :: Regex
}
@@ -194,23 +191,22 @@ validateTarballs :: ( Monad m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, Alternative m
, MonadFail m
)
=> TarballFilter
-> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
validateTarballs (TarballFilter tool versionRegex) dls = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ allDls downloadAll
let dlis = nubOrd $ dls ^.. each
%& indices (maybe (const True) (==) tool) %> each
%& indices (matchTest versionRegex . T.unpack . prettyVer)
% (viSourceDL % _Just `summing` viArch % each % each % each)
when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ dlis downloadAll
-- exit
e <- liftIO $ readIORef ref
@@ -227,21 +223,11 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
}
downloadAll dli = do
dirs <- liftIO getDirs
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
lift $ runLogger
($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
r <-
runLogger
. flip runReaderT appstate
. flip runReaderT settings
. runResourceT
. runE @'[DigestError
, DownloadFailed
@@ -253,21 +239,19 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
#endif
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
case tool of
Just GHCup -> do
let fn = "ghcup"
dir <- liftIO ghcupCacheDir
p <- liftE $ download dli dir (Just fn)
liftE $ checkDigest dli p
pure Nothing
Right _ -> do
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing
_ -> do
p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
pure Nothing
case r of
VRight (Just basePath) -> do
case _dlSubdir dli of

View File

@@ -6,7 +6,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
module BrickMain where
@@ -33,7 +32,6 @@ import Codec.Archive
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
@@ -60,12 +58,11 @@ import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
hiddenTools :: [Tool]
hiddenTools = [Stack]
data BrickData = BrickData
{ lr :: [ListResult]
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
deriving Show
@@ -100,7 +97,7 @@ keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , halt)
, (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction ((liftIO .) . set'))
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions
, \BrickSettings {..} ->
@@ -152,7 +149,12 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
<+> minHSize 15 (str "Version")
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes")
renderList' = withDefAttr listAttr . drawListElements renderItem True
renderList' = withDefAttr listAttr . drawListElements renderItem True . filterStack
filterStack appState'
| showAllTools as = appState'
| let v = clr appState'
nv = V.filter (\ListResult{..} -> lTool /= Stack) v
, otherwise = BrickInternalState { clr = nv, ix = ix appState' }
renderItem _ b listResult@ListResult{..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
@@ -327,25 +329,21 @@ moveCursor steps ais@BrickInternalState{..} direction =
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (BrickState
-> (Int, ListResult)
-> ReaderT AppState IO (Either String a))
withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a))
-> BrickState
-> EventM n (Next BrickState)
withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> continue as
Just (ix, e) -> do
suspendAndResume $ do
settings <- readIORef settings'
flip runReaderT settings $ action as (ix, e) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err)
Right _ -> liftIO $ putStrLn "Success"
getAppData Nothing >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
Just (ix, e) -> suspendAndResume $ do
action as (ix, e) >>= \case
Left err -> putStrLn ("Error: " <> err)
Right _ -> putStrLn "Success"
getAppData Nothing (pfreq . appData $ as) >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
-- | Update app data and list internal state based on new evidence.
@@ -366,9 +364,7 @@ constructList :: BrickData
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings =
replaceLR (filterVisible (showAllVersions appSettings)
(showAllTools appSettings))
(lr appD)
replaceLR (filterVisible (showAllVersions appSettings)) (lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
@@ -401,32 +397,21 @@ replaceLR filterF lr s =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True
| v
, not t
, not (elem (lTool e) hiddenTools) = True
| not v
, t
, not (elem Old (lTag e)) = True
| v
, t = True
| otherwise = not (elem Old (lTag e)) &&
not (elem (lTool e) hiddenTools)
filterVisible :: Bool -> ListResult -> Bool
filterVisible showAllVersions e | lInstalled e = True
| showAllVersions = True
| otherwise = not (elem Old (lTag e))
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -450,24 +435,24 @@ install' _ (_, ListResult {..}) = do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer $> vi
liftE $ installGHCBin dls lVer pfreq $> vi
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer $> vi
liftE $ installCabalBin dls lVer pfreq $> vi
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi
liftE $ upgradeGHCup dls Nothing False pfreq $> vi
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer $> vi
liftE $ installHLSBin dls lVer pfreq $> vi
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer $> vi
liftE $ installStackBin dls lVer pfreq $> vi
)
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg
runLogger $ $(logInfo) msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
@@ -499,16 +484,13 @@ set' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left (prettyShow e)
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
run (do
let vi = getVersionInfo lVer lTool dls
@@ -527,12 +509,8 @@ del' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left (prettyShow e)
changelog' :: (MonadReader AppState m, MonadIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
changelog' _ (_, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
@@ -561,8 +539,6 @@ settings' = unsafePerformIO $ do
})
dirs
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
@@ -578,9 +554,10 @@ logger' = unsafePerformIO
brickMain :: AppState
-> LoggerConfig
-> GHCupInfo
-> GHCupDownloads
-> PlatformRequest
-> IO ()
brickMain s l gi = do
brickMain s l av pfreq' = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
@@ -588,7 +565,7 @@ brickMain s l gi = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just gi)
eAppData <- getAppData (Just av) pfreq'
case eAppData of
Right ad ->
defaultMain
@@ -609,8 +586,8 @@ defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
getDownloads' :: IO (Either String GHCupDownloads)
getDownloads' = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
@@ -619,25 +596,29 @@ getGHCupInfo = do
runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ fmap _ghcupDownloads
$ liftE
$ getDownloadsF (GT.settings settings) (GT.dirs settings)
$ getDownloadsF (urlSource . GT.settings $ settings)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)
getAppData :: Maybe GHCupInfo
getAppData :: Maybe GHCupDownloads
-> PlatformRequest
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
getAppData mg pfreq' = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
r <- maybe getDownloads' (pure . Right) mg
runLogger . flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)
case r of
Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq'
pure $ Right $ BrickData (reverse lV) dls pfreq'
Left e -> pure $ Left [i|#{e}|]

View File

@@ -79,6 +79,8 @@ import qualified Text.Megaparsec.Char as MPC
data Options = Options
{
-- global options
@@ -174,7 +176,6 @@ data GHCCompileOptions = GHCCompileOptions
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
, setCompile :: Bool
, ovewrwiteVer :: Maybe Version
}
data UpgradeOpts = UpgradeInplace
@@ -292,7 +293,7 @@ com =
( Install
<$> info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal/HLS"
( progDesc "Install or update GHC/cabal"
<> footerDoc (Just $ text installToolFooter)
)
)
@@ -308,7 +309,7 @@ com =
"rm"
(info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal/HLS version"
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
@@ -763,15 +764,6 @@ ghcCompileOpts =
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
)
)
toolVersionParser :: Parser ToolVersion
@@ -815,47 +807,53 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
runLogger = myLoggerT loggerConfig
dirs <- getDirs
let simpleSettings = Settings False False Never Curl False GHCupURL
simpleAppState = AppState simpleSettings dirs defaultKeyBindings
runEnv = runLogger . flip runReaderT simpleAppState
mGhcUpInfo <- runEnv . runE $ readFromCache
case mGhcUpInfo of
VRight ghcupInfo -> do
VRight dls -> do
let allTags = filter (\t -> t /= Old)
$ join
$ M.elems
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool
$ availableToolVersions (_ghcupDownloads dls) tool
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
runLogger = myLoggerT loggerConfig
mpFreq <- runLogger . runE $ platformRequest
forFold mpFreq $ \pfreq ->
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
(Settings True False Never Curl False GHCupURL)
dirs'
defaultKeyBindings
ghcupInfo
pfreq
runEnv = runLogger . flip runReaderT appState
forFold mpFreq $ \pfreq -> do
dirs <- getDirs
let simpleSettings = Settings False False Never Curl False GHCupURL
simpleAppState = AppState simpleSettings dirs defaultKeyBindings
runEnv = runLogger . flip runReaderT simpleAppState
installedVersions <- runEnv $ listVersions (Just tool) criteria
mGhcUpInfo <- runEnv . runE $ readFromCache
forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do
installedVersions <- runEnv $ listVersions dls (Just tool) criteria pfreq
return $ T.unpack . prettyVer . lVer <$> installedVersions
@@ -976,8 +974,9 @@ bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings :: Options -> IO AppState
toSettings options = do
dirs <- getDirs
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
VRight r -> pure r
VLeft (V (JSONDecodeError e)) -> do
@@ -985,10 +984,10 @@ toSettings options = do
pure defaultUserSettings
_ -> do
die "Unexpected error!"
pure $ mergeConf options userConf
pure $ mergeConf options dirs userConf
where
mergeConf :: Options -> UserSettings -> (Settings, KeyBindings)
mergeConf Options{..} UserSettings{..} =
mergeConf :: Options -> Dirs -> UserSettings -> AppState
mergeConf Options{..} dirs UserSettings{..} =
let cache = fromMaybe (fromMaybe False uCache) optCache
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
@@ -996,7 +995,7 @@ toSettings options = do
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
in (Settings {..}, keyBindings)
in AppState (Settings {..}) dirs keyBindings
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
#else
@@ -1039,10 +1038,7 @@ upgradeOptsP =
describe_result :: String
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getDirs
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
CapturedProcess{..} <- executeOut "git" ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure _ -> pure numericVer
@@ -1052,11 +1048,6 @@ describe_result = $( LitE . StringL <$>
main :: IO ()
main = do
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
void enableAnsiSupport
let versionHelp = infoOption
( ("The GHCup Haskell installer, version " <>)
(head . lines $ describe_result)
@@ -1093,76 +1084,28 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer))
)
>>= \opt@Options {..} -> do
dirs <- getDirs
(settings, keybindings) <- toSettings opt
appstate@AppState{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir
createDirRecursive' (baseDir dirs)
createDirRecursive' baseDir
-- logger interpreter
logfile <- initGHCupFileLogging (logsDir dirs)
logfile <- flip runReaderT appstate $ initGHCupFileLogging
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, rawOutter = B.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
----------------------------------------
-- Getting download and platform info --
----------------------------------------
ghcupInfo <-
( runLogger
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF settings dirs
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
let appstate@AppState{dirs = Dirs{..}
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls, .. }
} = AppState settings dirs keybindings ghcupInfo pfreq
case optCommand of
Upgrade _ _ -> pure ()
_ -> runLogger $ flip runReaderT appstate $ checkForUpdates
-- ensure global tools
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
-------------------------
-- Effect interpreters --
-------------------------
let runInstTool' appstate' mInstPlatform =
let runInstTool' appstate' =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform)
. flip runReaderT appstate'
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1265,22 +1208,57 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
----------------------------------------
-- Getting download and platform info --
----------------------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
(GHCupInfo treq dls) <-
( runLogger
. flip runReaderT appstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF (urlSource settings)
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
case optCommand of
Upgrade _ _ -> pure ()
_ -> runLogger $ flip runReaderT appstate $ checkForUpdates dls pfreq
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
@@ -1296,8 +1274,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
_ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
Never -> runLogger ($(logError) $ T.pack $ prettyShow err)
_ -> runLogger ($(logError) [i|#{prettyShow err}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
@@ -1310,15 +1288,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
pure vi
)
>>= \case
@@ -1339,15 +1318,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installHLS InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
pure vi
)
>>= \case
@@ -1368,15 +1348,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installStack InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer Stack
liftE $ installStackBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
pure vi
)
>>= \case
@@ -1398,7 +1379,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setGHC' SetOptions{..} =
runSetGHC (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
v <- liftE $ fst <$> fromVersion' dls sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
@@ -1413,7 +1394,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setCabal' SetOptions{..} =
runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
v <- liftE $ fst <$> fromVersion' dls sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
@@ -1429,7 +1410,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setHLS' SetOptions{..} =
runSetHLS (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
v <- liftE $ fst <$> fromVersion' dls sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
@@ -1445,7 +1426,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setStack' SetOptions{..} =
runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack
v <- liftE $ fst <$> fromVersion' dls sToolVer Stack
liftE $ setStack (_tvVersion v)
pure v
)
@@ -1521,8 +1502,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of
#if defined(BRICK)
Interactive -> do
liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess
Interactive -> liftIO $ brickMain appstate loggerConfig dls pfreq >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@@ -1545,7 +1525,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List ListOptions {..} ->
runListGHC (do
l <- listVersions loTool lCriteria
l <- listVersions dls loTool lCriteria pfreq
liftIO $ printListResult lRawFormat l
pure ExitSuccess
)
@@ -1579,14 +1559,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
targetVer <- liftE $ compileGHC
targetVer <- liftE $ compileGHC dls
(first (GHCTargetVersion crossTarget) targetGhc)
ovewrwiteVer
bootstrapGhc
jobs
buildConfig
patchDir
addConfArgs
pfreq
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly
@@ -1605,8 +1585,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
Never -> runLogger $ $(logError) $ T.pack $ prettyShow err
_ -> runLogger ($(logError) [i|#{prettyShow err}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 9
@@ -1620,7 +1600,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup"))
runUpgrade (liftE $ upgradeGHCup target force) >>= \case
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
VRight v' -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
@@ -1637,13 +1617,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 11
ToolRequirements ->
flip runReaderT appstate
$ runLogger
runLogger
(runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
platform <- liftE getPlatform
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements
req <- getCommonRequirements platform treq ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
@@ -1679,7 +1658,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
if clOpen
then
flip runReaderT appstate $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
@@ -1696,40 +1674,36 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure ()
fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> Maybe ToolVersion
=> GHCupDownloads
-> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion av tv = fromVersion' av (toSetToolVer tv)
fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> SetToolVersion
=> GHCupDownloads
-> SetToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
fromVersion' av SetRecommended tool =
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool
?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
let vi = getVersionInfo (_tvVersion v) tool dls
fromVersion' av (SetToolVersion v) tool = do
let vi = getVersionInfo (_tvVersion v) tool av
case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi)
Right (PVP (major' :|[minor'])) ->
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of
Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi)
Right _ -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
fromVersion' av (SetToolTag Latest) tool =
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest av tool ?? TagNotFound Latest tool
fromVersion' av (SetToolTag Recommended) tool =
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool ?? TagNotFound Recommended tool
fromVersion' av (SetToolTag (Base pvp'')) GHC =
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' av SetNext tool = do
next <- case tool of
GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
@@ -1772,14 +1746,17 @@ fromVersion' SetNext tool = do
. sort
$ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls
let vi = getVersionInfo (_tvVersion next) tool av
pure (next, vi)
fromVersion' (SetToolTag t') tool =
fromVersion' _ (SetToolTag t') tool =
throwE $ TagNotFound t' tool
printListResult :: Bool -> [ListResult] -> IO ()
printListResult raw lr = do
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
no_color <- isJust <$> lookupEnv "NO_COLOR"
let
@@ -1803,15 +1780,9 @@ printListResult raw lr = do
. fmap
(\ListResult {..} ->
let marks = if
#if defined(IS_WINDOWS)
| lSet -> (color Green "IS")
| lInstalled -> (color Green "I ")
| otherwise -> (color Red "X ")
#else
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
#endif
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
@@ -1938,10 +1909,11 @@ checkForUpdates :: ( MonadReader AppState m
, MonadFail m
, MonadLogger m
)
=> m ()
checkForUpdates = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
lInstalled <- listVersions Nothing (Just ListInstalled)
=> GHCupDownloads
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
lInstalled <- listVersions dls Nothing (Just ListInstalled) pfreq
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
forM_ (getLatest dls GHCup) $ \(l, _) -> do

View File

@@ -14,52 +14,26 @@
# safety subshell to avoid executing anything in case this script is not downloaded properly
(
plat="$(uname -s)"
arch=$(uname -m)
ghver="0.1.14.1"
base_url="https://downloads.haskell.org/~ghcup"
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
case "${plat}" in
MSYS*|MINGW*)
: "${GHCUP_INSTALL_BASE_PREFIX:=/c}"
GHCUP_DIR=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup")
GHCUP_BIN=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup/bin")
: "${GHCUP_MSYS2:=${GHCUP_DIR}/msys64}"
;;
*)
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
export GHCUP_USE_XDG_DIRS
export GHCUP_USE_XDG_DIRS
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local/share}/ghcup
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
else
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
fi
;;
esac
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local/share}/ghcup
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
else
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
fi
: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
die() {
(>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
exit 2
}
warn() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;35m$1\\033[0m"
;;
*)
printf "\\033[0;35m%s\\033[0m\\n" "$1"
;;
esac
}
edo() {
"$@" || die "\"$*\" failed!"
}
@@ -69,133 +43,92 @@ eghcup() {
}
_eghcup() {
if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then
args="-s ${BOOTSTRAP_HASKELL_YAML}"
fi
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
"${GHCUP_BIN}/ghcup" ${args} "$@"
ghcup "$@"
else
"${GHCUP_BIN}/ghcup" ${args} --verbose "$@"
ghcup --verbose "$@"
fi
}
_done() {
case "${plat}" in
MSYS*|MINGW*)
echo
echo "All done!"
echo
echo "In a new powershell or cmd.exe session, now you can..."
echo
echo "Start a simple repl via:"
echo " ghci"
echo
echo "Start a new haskell project in the current directory via:"
echo " cabal init --interactive"
echo
echo "Install other GHC versions and tools via:"
echo " ghcup list"
echo " ghcup install <tool> <version>"
echo
echo "To install system libraries and update msys2/mingw64,"
echo "open the \"Mingw haskell shell\""
echo "and the \"Mingw package management docs\""
echo "desktop shortcuts."
;;
*)
echo
echo "All done!"
echo
echo "To start a simple repl, run:"
echo " ghci"
echo
echo "To start a new haskell project in the current directory, run:"
echo " cabal init --interactive"
echo
echo "To install other GHC versions and tools, run:"
echo " ghcup tui"
;;
esac
echo
echo "All done!"
echo
echo "To start a simple repl, run:"
echo " ghci"
echo
echo "To start a new haskell project in the current directory, run:"
echo " cabal init --interactive"
echo
echo "To install other GHC versions, run:"
echo " ghcup tui"
exit 0
}
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.14.1"
_base_url="https://downloads.haskell.org/~ghcup"
case "${plat}" in
case "${_plat}" in
"linux"|"Linux")
case "${arch}" in
case "${_arch}" in
x86_64|amd64)
# we could be in a 32bit docker container, in which
# case uname doesn't give us what we want
if [ "$(getconf LONG_BIT)" = "32" ] ; then
_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
_url=${base_url}/${ghver}/x86_64-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/x86_64-linux-ghcup-${_ghver}
else
die "Unknown long bit size: $(getconf LONG_BIT)"
fi
;;
i*86)
_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
;;
armv7*)
_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/armv7-linux-ghcup-${_ghver}
;;
aarch64|arm64|armv8l)
_url=${base_url}/${ghver}/aarch64-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/aarch64-linux-ghcup-${_ghver}
;;
*) die "Unknown architecture: ${arch}"
*) die "Unknown architecture: ${_arch}"
;;
esac
;;
"FreeBSD"|"freebsd")
case "${arch}" in
case "${_arch}" in
x86_64|amd64)
;;
i*86)
die "i386 currently not supported!"
;;
*) die "Unknown architecture: ${arch}"
*) die "Unknown architecture: ${_arch}"
;;
esac
_url=${base_url}/${ghver}/x86_64-portbld-freebsd-ghcup-${ghver}
_url=${_base_url}/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
;;
"Darwin"|"darwin")
case "${arch}" in
case "${_arch}" in
x86_64|amd64)
;;
i*86)
die "i386 currently not supported!"
;;
*) die "Unknown architecture: ${arch}"
*) die "Unknown architecture: ${_arch}"
;;
esac
_url=${base_url}/${ghver}/x86_64-apple-darwin-ghcup-${ghver} ;;
MSYS*|MINGW*)
case "${arch}" in
x86_64|amd64)
_url=https://downloads.haskell.org/~ghcup/tmp/x86_64-mingw64-ghcup-9.exe
;;
*) die "Unknown architecture: ${arch}"
;;
esac
;;
*) die "Unknown platform: ${plat}"
_url=${_base_url}/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
*) die "Unknown platform: ${_plat}"
;;
esac
case "${plat}" in
MSYS*|MINGW*)
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup.exe
edo chmod +x "${GHCUP_BIN}"/ghcup.exe
;;
*)
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
edo chmod +x "${GHCUP_BIN}"/ghcup
;;
esac
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
edo chmod +x "${GHCUP_BIN}"/ghcup
edo mkdir -p "${GHCUP_DIR}"
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
@@ -204,6 +137,8 @@ download_ghcup() {
# shellcheck disable=SC1090
edo . "${GHCUP_DIR}"/env
eghcup upgrade
unset _plat _arch _url _ghver _base_url
}
@@ -212,22 +147,14 @@ echo "Welcome to Haskell!"
echo
echo "This script will download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer"
echo " (for managing GHC/cabal versions)"
echo " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool for managing Haskell software"
echo " * stack - (optional) A cross-platform program for developing Haskell projects"
echo " * hls - (optional) A language server for developers to integrate with their editor/IDE"
echo " * cabal - The Cabal build tool"
echo
if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
echo "ghcup installs only into the following directory,"
echo "which can be removed anytime:"
case "${plat}" in
MSYS*|MINGW*)
echo " $(cygpath -w "$GHCUP_DIR")"
;;
*)
echo " $GHCUP_DIR"
;;
esac
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
else
echo "ghcup installs into XDG directories as long as"
echo "'GHCUP_USE_XDG_DIRS' is set."
@@ -235,8 +162,8 @@ fi
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Press ENTER to proceed or ctrl-c to abort."
warn "Note that this script can be re-run at any given time."
printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed or ctrl-c to abort."
printf "\\033[0;35m%s\\033[0m\\n" "Note that this script can be re-run at any given time."
echo
# Wait for user input to continue.
# shellcheck disable=SC2034
@@ -254,12 +181,12 @@ else
fi
echo
echo "$(if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then ghcup -s "${BOOTSTRAP_HASKELL_YAML}" tool-requirements ; else ghcup tool-requirements ; fi)"
echo "$(ghcup tool-requirements)"
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Press ENTER to proceed or ctrl-c to abort."
warn "Installation may take a while."
printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed or ctrl-c to abort."
printf "\\033[0;35m%s\\033[0m\\n" "Installation may take a while."
echo
# Wait for user input to continue.
@@ -272,55 +199,21 @@ eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
adjust_cabal_config() {
edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$HOME"/AppData/Roaming/cabal/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
}
case "${plat}" in
MSYS*|MINGW*)
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Create an initial cabal.config including relevant msys2 paths (recommended)?"
warn "[Y] Yes [N] No [?] Help (default is \"Y\")."
echo
while true; do
read -r mingw_answer </dev/tty
case $mingw_answer in
[Yy]* | "")
adjust_cabal_config
break ;;
[Nn]*)
echo "Make sure that your global cabal.config references the correct mingw64 paths (extra-prog-path, extra-include-dirs and extra-lib-dirs)."
echo "And set the environment variable GHCUP_MSYS2 to the root path of your msys2 installation."
sleep 5
break ;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, create a cabal.config with pre-set paths to msys2/mingw64 (default)"
echo "N - No, leave the current/default cabal config untouched"
echo
echo "Please make your choice and press ENTER."
;;
esac
done
else
adjust_cabal_config
fi
;;
esac
edo cabal new-update
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Installation done!"
printf "\\033[0;35m%s\\033[0m\\n" ""
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Do you want to install haskell-language-server (HLS) now?"
warn "HLS is a language-server that provides IDE-like functionality"
warn "and can integrate with different editors, such as Vim, Emacs, VS Code, Atom, ..."
warn "Also see https://github.com/haskell/haskell-language-server/blob/master/README.md"
warn ""
warn "[Y] Yes [N] No [?] Help (default is \"N\")."
warn ""
printf "\\033[0;35m%s\\033[0m\\n" "Do you want to install haskell-language-server (HLS) now?"
printf "\\033[0;35m%s\\033[0m\\n" "HLS is a language-server that provides IDE-like functionality"
printf "\\033[0;35m%s\\033[0m\\n" "and can integrate with different editors, such as Vim, Emacs, VS Code, Atom, ..."
printf "\\033[0;35m%s\\033[0m\\n" "Also see https://github.com/haskell/haskell-language-server/blob/master/README.md"
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Answer with YES or NO and press ENTER."
printf "\\033[0;35m%s\\033[0m\\n" ""
while true; do
read -r hls_answer </dev/tty
@@ -329,43 +222,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
[Yy]*)
eghcup --cache install hls
break ;;
[Nn]* | "")
[Nn]*)
break ;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, install the haskell-langauge-server"
echo "N - No, don't install anything more (default)"
echo
echo "Please make your choice and press ENTER."
;;
esac
done
warn "Do you want to install stack now?"
warn "Stack is a haskell build tool similar to cabal that is used by some projects."
warn "Also see https://docs.haskellstack.org/"
warn ""
warn "[Y] Yes [N] No [?] Help (default is \"N\")."
warn ""
while true; do
read -r stack_answer </dev/tty
case $stack_answer in
[Yy]*)
eghcup --cache install stack
break ;;
[Nn]* | "")
break ;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, install stack"
echo "N - No, don't install anything more (default)"
echo
echo "Please make your choice and press ENTER."
;;
echo "Please type YES or NO and press enter.";;
esac
done
@@ -398,31 +258,32 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
esac
warn ""
warn "Detected ${MY_SHELL} shell on your system..."
warn "If you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\""
warn ""
warn "[Y] Yes [N] No [?] Help (default is \"Y\")."
warn ""
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Detected ${MY_SHELL} shell on your system..."
printf "\\033[0;35m%s\\033[0m\\n" "If you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\""
printf "\\033[0;35m%s\\033[0m\\n" "answer with YES, otherwise with NO and press ENTER."
printf "\\033[0;35m%s\\033[0m\\n" ""
while true; do
read -r next_answer </dev/tty
case $next_answer in
[Nn]*)
_done ;;
[Yy]* | "")
[Yy]*)
case $MY_SHELL in
"") break ;;
fish)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
mkdir -p "${GHCUP_PROFILE_FILE%/*}"
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
bash)
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
case "${plat}" in
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
case "$(uname -s)" in
"Darwin"|"darwin")
if ! grep -q "ghcup-env" "${HOME}/.bash_profile" ; then
echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
@@ -432,28 +293,22 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
break ;;
zsh)
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
esac
warn "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
warn "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
_done
;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, update my \"${GHCUP_PROFILE_FILE}\" (default)"
echo "N - No, don't mess with my configuration"
echo
echo "Please make your choice and press ENTER."
;;
[Nn]*)
_done ;;
*)
echo "Please type YES or NO and press enter.";;
esac
done
fi
_done
)
# vim: tabstop=4 shiftwidth=4 expandtab

View File

@@ -1,400 +0,0 @@
<#
.SYNOPSIS
Script to bootstrap a Haskell environment
.DESCRIPTION
This is the windows GHCup installer, installing:
* ghcup - The Haskell toolchain installer"
* ghc - The Glasgow Haskell Compiler"
* msys2 - Unix-style toolchain needed for dependencies and tools
* cabal - The Cabal build tool for managing Haskell software"
* stack - (optional) A cross-platform program for developing Haskell projects"
* hls - (optional) A language server for developers to integrate with their editor/IDE"
#>
param (
# Run a non-interactive installation
[switch]$Silent,
# Specify the install root (default: 'C:\')
[string]$InstallDir,
# Instead of installing a new MSys2, use an existing installation
[string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir,
# Perform a quick installation, omitting some expensive operations (you may have to install dependencies yourself later)
[bool]$Quick,
# Overwrite (or rather backup) a previous install
[bool]$Overwrite
)
function Print-Msg {
param ( [Parameter(Mandatory=$true, HelpMessage='String to output')][string]$msg, [string]$color = "Green" )
Write-Host ('{0}' -f $msg) -ForegroundColor $color
}
function Create-Shortcut {
param ( [Parameter(Mandatory=$true,HelpMessage='Target path')][string]$SourceExe, [Parameter(Mandatory=$true,HelpMessage='Arguments to the path/exe')][AllowEmptyString()]$ArgumentsToSourceExe, [Parameter(Mandatory=$true,HelpMessage='The destination of the desktop link')][string]$DestinationPath )
$WshShell = New-Object -comObject WScript.Shell
$Shortcut = $WshShell.CreateShortcut($DestinationPath)
$Shortcut.TargetPath = $SourceExe
if($ArgumentsToSourceExe) {
$Shortcut.Arguments = $ArgumentsToSourceExe
}
$Shortcut.Save()
}
function Add-EnvPath {
param(
[Parameter(Mandatory=$true,HelpMessage='The Path to add to Users environment')]
[string] $Path,
[ValidateSet('Machine', 'User', 'Session')]
[string] $Container = 'Session'
)
if ($Container -eq 'Session') {
$envPaths = [Collections.Generic.List[String]]($env:Path -split ([IO.Path]::PathSeparator))
if ($envPaths -notcontains $Path) {
$envPaths.Add($Path)
$env:PATH = $envPaths -join ([IO.Path]::PathSeparator)
}
}
else {
[Microsoft.Win32.RegistryHive]$hive, $keyPath = switch ($Container) {
'Machine' { 'LocalMachine', 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment' }
'User' { 'CurrentUser', 'Environment' }
}
$hiveKey = $envKey = $null
try {
$hiveKey = [Microsoft.Win32.RegistryKey]::OpenBaseKey($hive, 'Default')
$envKey = $hiveKey.OpenSubKey($keyPath, $true)
$rawPath = $envKey.GetValue('PATH', '', 'DoNotExpandEnvironmentNames')
$envPaths = [Collections.Generic.List[String]]($rawPath -split ([IO.Path]::PathSeparator))
if ($envPaths -notcontains $Path) {
$envPaths.Add($Path)
$envKey.SetValue('PATH', ($envPaths -join ([IO.Path]::PathSeparator)), 'ExpandString')
}
}
finally {
if ($envKey) { $envKey.Dispose() }
if ($hiveKey) { $hiveKey.Dispose() }
}
}
}
filter Get-FileSize {
'{0:N2} {1}' -f $(
if ($_ -lt 1kb) { $_, 'Bytes' }
elseif ($_ -lt 1mb) { ($_/1kb), 'KB' }
elseif ($_ -lt 1gb) { ($_/1mb), 'MB' }
elseif ($_ -lt 1tb) { ($_/1gb), 'GB' }
elseif ($_ -lt 1pb) { ($_/1tb), 'TB' }
else { ($_/1pb), 'PB' }
)
}
function Get-FileWCSynchronous{
param(
[Parameter(Mandatory=$true)]
[string]$url,
[string]$destinationFolder="$env:USERPROFILE\Downloads",
[switch]$includeStats
)
$wc = New-Object -TypeName Net.WebClient
$wc.UseDefaultCredentials = $true
$destination = Join-Path -Path $destinationFolder -ChildPath ($url | Split-Path -Leaf)
$start = Get-Date
$wc.DownloadFile($url, $destination)
$elapsed = ((Get-Date) - $start).ToString('hh\:mm\:ss')
$totalSize = (Get-Item -Path $destination).Length | Get-FileSize
if ($includeStats.IsPresent){
[PSCustomObject]@{Name=$MyInvocation.MyCommand;TotalSize=$totalSize;Time=$elapsed}
}
Get-Item -Path $destination | Unblock-File
}
function Test-AbsolutePath {
Param (
[Parameter(Mandatory=$True)]
[ValidateScript({[System.IO.Path]::IsPathRooted($_)})]
[String]$Path
)
}
function Exec
{
[CmdletBinding()]
param(
[Parameter(Position = 0, Mandatory = 1)][string]$cmd,
[Parameter()][string]$errorMessage,
[parameter(ValueFromRemainingArguments = $true)]
[string[]]$Passthrough
)
& $cmd @Passthrough
if ($lastexitcode -ne 0) {
if (!($errorMessage)) {
throw ('Exec: Error executing command {0} with arguments ''{1}''' -f $cmd, "$Passthrough")
} else {
throw ('Exec: ' + $errorMessage)
}
}
}
$ErrorActionPreference = 'Stop'
$GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
if ($GhcupBasePrefixEnv) {
$defaultGhcupBasePrefix = $GhcupBasePrefixEnv
} else {
$defaultGhcupBasePrefix = 'C:\'
}
if ($Silent -and !($InstallDir)) {
$GhcupBasePrefix = $defaultGhcupBasePrefix
} elseif ($InstallDir) {
if (!(Test-Path -LiteralPath ('{0}' -f $InstallDir) -IsValid)) {
Print-Msg -color Red -msg "Not a valid directory!"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$InstallDir")) {
Print-Msg -color Red -msg "Non-absolute Path specified!"
Exit 1
} else {
$GhcupBasePrefix = $InstallDir
}
} else {
while ($true) {
Print-Msg -color Magenta -msg ('Where to install to (this should be a short Path, preferably a Drive like ''C:\''){1}Press enter to accept the default [{0}]:' -f $defaultGhcupBasePrefix, "`n")
$basePrefixPrompt = Read-Host
$GhcupBasePrefix = ($defaultGhcupBasePrefix,$basePrefixPrompt)[[bool]$basePrefixPrompt]
if (!($GhcupBasePrefix.EndsWith('\'))) {
$GhcupBasePrefix = ('{0}\' -f $GhcupBasePrefix)
}
if (!($GhcupBasePrefix)) {
Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Test-Path -LiteralPath ('{0}' -f $GhcupBasePrefix))) {
Print-Msg -color Red -msg "Directory does not exist, need to specify an existing Drive/Directory"
} elseif (!(Split-Path -IsAbsolute -Path "$GhcupBasePrefix")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
} else {
Break
}
}
}
Print-Msg -msg ('Setting env variable GHCUP_INSTALL_BASE_PREFIX to ''{0}''' -f $GhcupBasePrefix)
$null = [Environment]::SetEnvironmentVariable("GHCUP_INSTALL_BASE_PREFIX", $GhcupBasePrefix, [System.EnvironmentVariableTarget]::User)
$GhcupDir = ('{0}\ghcup' -f $GhcupBasePrefix)
$MsysDir = ('{0}\msys64' -f $GhcupDir)
$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
$BootstrapUrl = 'https://www.haskell.org/ghcup/sh/bootstrap-haskell-windows'
$GhcupMsys2 = [System.Environment]::GetEnvironmentVariable('GHCUP_MSYS2', 'user')
Print-Msg -msg 'Preparing for GHCup installation...'
if (Test-Path -LiteralPath ('{0}' -f $GhcupDir)) {
Print-Msg -msg ('GHCup already installed at ''{0}''...' -f $GhcupDir)
if ($Overwrite) {
$decision = 0
} elseif (!($Silent)) {
$decision = $Host.UI.PromptForChoice('Install GHCup'
, 'GHCup is already installed, what do you want to do?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Reinstall'
'&Continue'
'&Abort'), 1)
} else {
$decision = 1
}
if ($decision -eq 0) {
$suffix = [IO.Path]::GetRandomFileName()
Print-Msg -msg ('Backing up {0} to {0}-{1} ...' -f $GhcupDir, $suffix)
Rename-Item -Path ('{0}' -f $GhcupDir) -NewName ('{0}-{1}' -f $GhcupDir, $suffix)
} elseif ($decision -eq 1) {
Print-Msg -msg 'Continuing installation...'
} elseif ($decision -eq 2) {
Exit 0
}
}
$null = New-Item -Path ('{0}' -f $GhcupDir) -ItemType 'directory' -ErrorAction SilentlyContinue
$null = New-Item -Path ('{0}' -f $GhcupDir) -Name 'bin' -ItemType 'directory' -ErrorAction SilentlyContinue
Print-Msg -msg 'First checking for Msys2...'
if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
if ($Silent) {
$msys2Decision = 0
} else {
$msys2Decision = $Host.UI.PromptForChoice('Install MSys2'
, 'Do you want GHCup to install a default MSys2 toolchain (recommended)?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
'&No'), 0)
}
if ($msys2Decision -eq 0) {
Print-Msg -msg ('...Msys2 doesn''t exist, installing into {0} ...this may take a while' -f $MsysDir)
# Download the archive
Print-Msg -msg 'Downloading Msys2 archive...'
$archive = 'msys2-x86_64-latest.sfx.exe'
if (Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) {
Exec "curl.exe" '-o' ('{0}\{1}' -f $env:TEMP, $archive) ('https://repo.msys2.org/distrib/{0}' -f $archive)
} else {
Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder "$env:TEMP" -includeStats
}
Print-Msg -msg 'Extracting Msys2 archive...'
$null = & "$env:TEMP\$archive" '-y' ('-o{0}' -f $GhcupDir) # Extract
Remove-Item -Path ('{0}/{1}' -f $env:TEMP, $archive)
Print-Msg -msg 'Processing MSYS2 bash for first time use...'
Exec "$Bash" '-lc' 'exit'
Exec "$env:windir\system32\taskkill.exe" /F /FI `"MODULES eq msys-2.0.dll`"
Print-Msg -msg 'Upgrading full system...'
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
Print-Msg -msg 'Upgrading full system twice...'
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
if ($Quick) {
$ghcBuildDeps = $Quick
} elseif (!($Silent)) {
$ghcBuildDeps = $Host.UI.PromptForChoice('Install Dependencies'
, 'Install various dependencies to be able to build GHC itself and make use of ''ghcup compile'' command? (recommended, however this might take a while)'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
'&No'), 0)
} else {
$ghcBuildDeps = 0
}
if ($ghcBuildDeps -eq 0) {
Print-Msg -msg 'Installing GHC Build Dependencies...'
Exec "$Bash" '-lc' 'pacman --noconfirm -S --needed git tar curl wget base-devel gettext binutils autoconf make libtool automake python p7zip patch unzip mingw-w64-x86_64-toolchain mingw-w64-x86_64-gcc mingw-w64-x86_64-gdb mingw-w64-x86_64-python2 mingw-w64-x86_64-python3-sphinx'
}
Print-Msg -msg 'Updating SSL root certificate authorities...'
Exec "$Bash" '-lc' 'pacman --noconfirm -S ca-certificates'
Print-Msg -msg 'Setting default home directory...'
Exec "$Bash" '-lc' "sed -i -e 's/db_home:.*$/db_home: windows/' /etc/nsswitch.conf"
} elseif ($msys2Decision -eq 1) {
Print-Msg -color Yellow -msg 'Skipping MSys2 installation.'
while ($true) {
if ($GhcupMsys2) {
$defaultMsys2Dir = $GhcupMsys2
Print-Msg -color Magenta -msg ('Input existing MSys2 toolchain directory. Press enter to accept the default [{0}]:' -f $defaultMsys2Dir)
$MsysDirPrompt = Read-Host
$MsysDir = ($defaultMsys2Dir,$MsysDirPrompt)[[bool]$MsysDirPrompt]
} else {
Print-Msg -color Magenta -msg 'Input existing MSys2 toolchain directory:'
$MsysDir = Read-Host
}
if (!($MsysDir)) {
Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Test-Path -LiteralPath ('{0}' -f $MsysDir))) {
Print-Msg -color Red -msg ('MSys2 installation at ''{0}'' could not be found!' -f $MsysDir)
} elseif (!(Split-Path -IsAbsolute -Path "$MsysDir")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
} else {
Break
}
}
Print-Msg -msg ('Setting GHCUP_MSYS2 env var to ''{0}''' -f $MsysDir)
$null = [Environment]::SetEnvironmentVariable("GHCUP_MSYS2", $MsysDir, [System.EnvironmentVariableTarget]::User)
$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
}
} else {
Print-Msg -msg ('...Msys2 found in {0} ...skipping Msys2 installation.' -f $MsysDir)
}
Print-Msg -msg 'Creating shortcuts...'
Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe '-mingw64' -DestinationPath ('{0}\Desktop\Mingw haskell shell.lnk' -f $HOME)
Create-Shortcut -SourceExe 'https://www.msys2.org/docs/package-management' -ArgumentsToSourceExe '' -DestinationPath ('{0}\Desktop\Mingw package management docs.url' -f $HOME)
Print-Msg -msg ('Adding {0}\bin to Users Path...' -f $GhcupDir)
Add-EnvPath -Path ('{0}\bin' -f ([System.IO.Path]::GetFullPath("$GhcupDir"))) -Container 'User'
if ($CabalDir) {
$CabDirEnv = $CabalDir
if (!($CabDirEnv)) {
Print-Msg -color Red -msg "No directory specified!"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
Exit 1
}
} elseif (!($Silent)) {
while ($true) {
$defaultCabalDir = ('{0}\cabal' -f $GhcupBasePrefix)
Print-Msg -color Magenta -msg ('Specify Cabal directory (this is where haskell packages end up). Press enter to accept the default [{0}]:' -f $defaultCabalDir)
$CabalDirPrompt = Read-Host
$CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt]
if (!($CabDirEnv)) {
Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
} else {
Break
}
}
} else {
$CabDirEnv = ('{0}\cabal' -f $GhcupBasePrefix)
}
$CabalDirFull = [System.IO.Path]::GetFullPath("$CabDirEnv")
Print-Msg -msg ('Setting CABAL_DIR to ''{0}''' -f $CabalDirFull)
$null = [Environment]::SetEnvironmentVariable("CABAL_DIR", $CabalDirFull, [System.EnvironmentVariableTarget]::User)
Print-Msg -msg 'Starting GHCup installer...'
$Msys2Shell = ('{0}\msys2_shell.cmd' -f $MsysDir)
if ($Silent) {
$SilentExport = 'export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 ;'
} else {
$SilentExport = ''
}
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell")) {
Exec "$Bash" '-lc' ('{4} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull)
} else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; curl --proto =https --tlsv1.2 -sSf -k {0} | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull)
}
# SIG # Begin signature block
# MIID4QYJKoZIhvcNAQcCoIID0jCCA84CAQExCzAJBgUrDgMCGgUAMGkGCisGAQQB
# gjcCAQSgWzBZMDQGCisGAQQBgjcCAR4wJgIDAQAABBAfzDtgWUsITrck0sYpfvNR
# AgEAAgEAAgEAAgEAAgEAMCEwCQYFKw4DAhoFAAQUVqKek181kF/Jx/P7z176herc
# ZyCgggH/MIIB+zCCAWSgAwIBAgIQGOezhGS1A5tHh9VubW0liDANBgkqhkiG9w0B
# AQUFADAYMRYwFAYDVQQDDA1KdWxpYW4gT3NwYWxkMB4XDTIxMDUzMDE4Mzk1OVoX
# DTI1MDUzMDAwMDAwMFowGDEWMBQGA1UEAwwNSnVsaWFuIE9zcGFsZDCBnzANBgkq
# hkiG9w0BAQEFAAOBjQAwgYkCgYEAs76XCXYPM14buR1RkVKhOB8pyM4Df6kPaz75
# nkbA0nq1VmMhBfCYFWyYHd7jniqTH0LoAKGGquN1bniREaCP9j2pFWpMIgLpQH3H
# +jpsfmxV2BTG8q+Jok88gTXS1FlAk72E85zO/Jhr6Fja1aFYAdibBRsRxcVMTVh7
# 4AGLNGUCAwEAAaNGMEQwEwYDVR0lBAwwCgYIKwYBBQUHAwMwHQYDVR0OBBYEFC+R
# hdhPo0Ty5HnzHyo1pN35IfZQMA4GA1UdDwEB/wQEAwIHgDANBgkqhkiG9w0BAQUF
# AAOBgQAl3IdBVIwbJJDp7BksMYPeM4ivB3UyNvlw8aVxGwAzNgdSaezYIdMFtKXV
# CSv5bd4VnFRAPDJW9dhW0h3SkeJUoklUxMjKXhR3qygQhSxPDjIatAuOCffGACba
# ZZ7Om40b+pKXc6i/HnlApk9DGbXJ59bFcLGGcZ9QjoUae6Ex1DGCAUwwggFIAgEB
# MCwwGDEWMBQGA1UEAwwNSnVsaWFuIE9zcGFsZAIQGOezhGS1A5tHh9VubW0liDAJ
# BgUrDgMCGgUAoHgwGAYKKwYBBAGCNwIBDDEKMAigAoAAoQKAADAZBgkqhkiG9w0B
# CQMxDAYKKwYBBAGCNwIBBDAcBgorBgEEAYI3AgELMQ4wDAYKKwYBBAGCNwIBFTAj
# BgkqhkiG9w0BCQQxFgQUosm9nN1JgajqSBa1cUwxxhLrAsYwDQYJKoZIhvcNAQEB
# BQAEgYCnKzfsH1aDjS6xkC/uymjaBowHSnh6nFu2AkjcKu8RgcBZzP5SLBXgU9wm
# aED5Ujwyq3Qre+TGVRUqwkEauDhQiX2A008G00fRO6+di6yJRCRn5eaRAbdU3Xww
# E5VhEwLBnwzWrvLKtdEclhgUCo5Tq87QMXVdgX4aRmunl4ZE+Q==
# SIG # End signature block

View File

@@ -2,7 +2,11 @@ packages: ./ghcup.cabal
optimization: 2
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
tests: True
flags: +tui
@@ -16,4 +20,4 @@ constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell, language-c
allow-newer: base, ghc-prim, template-haskell

View File

@@ -1,2 +0,0 @@
-- windows picks weird version
constraints: any.hsc2hs ==0.68.7

View File

@@ -170,6 +170,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-portbld-freebsd.tar.bz2
dlSubdir: ghc-7.10.3
dlHash: 2aa396edd2bb651f4bc7eef7a396913ea24923de5aafdc76df6295333e487e48
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-7.10.3
dlHash: 63e1689fc9e2809ae4d7f422b4dc810052e54c9aa2afd08746e234180e711dde
A_32:
Linux_Debian:
unknown_versioning: &ghc-7103-32-deb8
@@ -236,6 +241,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.0.2
dlHash: b36a20e5cae24d70bbb6116ae486f21811e9384f15d3892d260f02fba3e3bb8c
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.0.2
dlHash: 8c42c1f4af995205b9816a1e97e2752fe758544c1f5fe77958cdcd319c9c2d53
A_32:
Linux_Debian:
'( >= 7 && < 8 )':
@@ -300,6 +310,11 @@ ghcupDownloads:
dlSubdir: ghc-8.2.2
dlHash: cd351c704b92b9af23994024df07de8ca7090ea7675d5c8b14b2be857a46d804
unknown_versioning: *ghc-822-64-fbsd11
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.2.2
dlHash: 1e033df2092aa546e763e7be63167720b32df64f76673ea1ce7ae7c9f564b223
A_32:
Linux_Debian:
'( >= 7 && < 8 )':
@@ -359,6 +374,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-portbld11-freebsd.tar.xz
dlSubdir: ghc-8.4.1
dlHash: e748daec098445c6190090fe32bb2817a1140553be5acd2188e1af05ad24e5aa
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.4.1
dlHash: 328b013fc651d34e075019107e58bb6c8a578f0155cf3ad4557e6f2661b03131
A_32:
Linux_Debian:
unknown_versioning: &ghc-841-32-deb8
@@ -414,6 +434,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.4.2
dlHash: e9ed417fdf94c2ff2c6e344ed16f332bf6b591511f6442c0d9ea94854882b66c
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.4.2
dlHash: 797634aa9812fc6b2084a24ddb4fde44fa83a2f59daea82e0af81ca3dd323fde
A_32:
Linux_Debian:
unknown_versioning: &ghc-842-32-deb8
@@ -464,6 +489,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.4.3
dlHash: af0b455f6c46b9802b4b48dad996619cfa27cc6e2bf2ce5532387b4a8c00aa64
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.4.3
dlHash: 8a83cfbf9ae84de0443c39c93b931693bdf2a6d4bf163ffb41855f80f4bf883e
A_32:
Linux_Debian:
unknown_versioning: &ghc-843-32-deb8
@@ -532,6 +562,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-portbld-freebsd11.tar.xz
dlSubdir: ghc-8.4.4
dlHash: 44fbd142d1c355d6110595c59c760e2c73866ff9259ec85ebf814edb244d1940
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.4.4
dlHash: da29dbb0f1199611c7d5bb7b0dd6a7426ca98f67dfd6da1526b033cd3830dc05
A_32:
Linux_Debian:
unknown_versioning: &ghc-844-32-deb8
@@ -592,6 +627,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.6.1
dlHash: 51403b054a3a649039ac988e1d1112561f96750bfced63df864091a3fab36f08
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.6.1
dlHash: 7316d9cb5e486460476754f872c7bac30ee2082e42f46da4342f872d10b88099
A_32:
Linux_Debian:
unknown_versioning: &ghc-861-32-deb8
@@ -638,6 +678,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.6.2
dlHash: 8ec46a25872226dd7e5cf7271e3f3450c05f32144b96e6b9cb44cc4079db50dc
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.6.2
dlHash: 9a398e133cab09ff2610834337355d4e26c35e0665403fb9ff8db79315f74d3d
A_32:
Linux_Debian:
unknown_versioning: &ghc-862-32-deb8
@@ -702,6 +747,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.6.3
dlHash: bc2419fa180f8a7808c49775987866435995df9bdd9ce08bcd38352d63ba6031
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.6.3
dlHash: 2fec383904e5fa79413e9afd328faf9bc700006c8c3d4bcdd8d4f2ccf0f7fa2a
A_32:
Linux_Debian:
unknown_versioning: &ghc-863-32-deb8
@@ -752,6 +802,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.6.4
dlHash: cccb58f142fe41b601d73690809f6089f7715b6a50a09aa3d0104176ab4db09e
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.6.4
dlHash: e8d021b7a90772fc559862079da20538498d991956d7557b468ca19ddda22a08
A_32:
Linux_Debian:
unknown_versioning: &ghc-864-32-deb9
@@ -820,6 +875,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.6.5/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.6.5
dlHash: 83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.6.5
dlHash: 457024c6ea43bdce340af428d86319931f267089398b859b00efdfe2fd4ce93f
A_32:
Linux_Debian:
unknown_versioning: &ghc-865-32-deb9
@@ -890,6 +950,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.8.1
dlHash: 38c8917b47c31bedf58c9305dfca3abe198d8d35570366f0773c4e2948bd8abe
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.8.1
dlHash: 29e56e6af38017a5a76b2b6995a39d3988fa58131e4b55b62dd317ba7186ac9b
A_32:
Linux_Debian:
unknown_versioning: &ghc-881-32-deb9
@@ -949,6 +1014,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.8.2
dlHash: 25c5c1a70036abf3f22b2b19c10d26adfdb08e8f8574f89d4b2042de5947f990
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.8.2
dlHash: e25d9b16ee62cafc7387af2cd021eea676a99cd2c32b83533b016162c63065d9
A_32:
Linux_Debian:
unknown_versioning: &ghc-882-32-deb9
@@ -1013,6 +1083,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.8.3/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.8.3
dlHash: 569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.8.3
dlHash: e22586762af0911c06e8140f1792e3ca381a3a482a20d67b9054883038b3a422
A_32:
Linux_Debian:
unknown_versioning: &ghc-883-32-deb9
@@ -1087,6 +1162,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.8.4/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.8.4
dlHash: 8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.8.4
dlHash: d185055d2c8dc3bfe5b88afd59d6877eb1e722b672d1c9649f18296e148ed71f
A_32:
Linux_Debian:
unknown_versioning: &ghc-884-32-deb9
@@ -1164,6 +1244,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.10.1
dlHash: e8646ec9b60fd40aa9505ee055f22f04601290ab7a1342c2cf37c34de9d3f142
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.10.1
dlHash: 38a3166ea50cccd5bae7e1680eae3aae2b4ae31b61f82a1d8168fb821f43bd67
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8101-32-deb9
@@ -1254,6 +1339,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-unknown-freebsd.tar.xz
dlSubdir: ghc-8.10.2
dlHash: 9e5957f3497f4b58ecd3699568d9caaa11a47a6d7e902032c261e450fa0f6686
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.10.2
dlHash: dcae4c173b9896e07ff048de5509aa0a4537233150e06e5ce8848303dfadc176
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8102-32-deb9
@@ -1286,7 +1376,6 @@ ghcupDownloads:
dlHash: bb9c97826b1f4d7a8ef8bce0616b612f1ded10480ef10fcf7fb4e6d10a6681c8
8.10.3:
viTags:
- old
- base-4.14.1.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.3/docs/html/users_guide/8.10.3-notes.html
viSourceDL:
@@ -1344,6 +1433,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.3/ghc-8.10.3-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.10.3
dlHash: 749007e995104db05cf6e3ad5bc36238cab8afac8055145661e5730e8f8af040
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.3/ghc-8.10.3-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.10.3
dlHash: 927a6c699533a115cd49772ef2c753d9af2c13bf9f0b2d3bd13645cc6a144ee3
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8103-32-deb9
@@ -1376,6 +1470,7 @@ ghcupDownloads:
dlHash: b823b58cae36fbac0741680ca7605180fa4cf4c6ae439123d282184b94d32fd6
8.10.4:
viTags:
- Recommended
- base-4.14.1.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.4/docs/html/users_guide/8.10.4-notes.html
viSourceDL:
@@ -1383,7 +1478,7 @@ ghcupDownloads:
dlSubdir: ghc-8.10.4
dlHash: 52af871b4e08550257d720c2944ac85727d0b948407cef1bebfe7508c224910e
viPostRemove: *ghc-post-remove
viPreCompile: &ghc-pre-compile "If you have autoconf >= 2.70 you'll need this patch https://gitlab.haskell.org/ghc/ghc/-/snippets/2040 (see the --patchdir option)"
viPreCompile: "If you have autoconf >= 2.70 you'll need this patch https://gitlab.haskell.org/ghc/ghc/-/snippets/2040 (see the --patchdir option)"
viArch:
A_64:
Linux_Debian:
@@ -1434,6 +1529,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.10.4
dlHash: c9776a2ccf9629b03e967206a507fcdcb6c5189800a626e9461ababf6733c357
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.10.4
dlHash: e9175a276504c3390a5e0084954e6997d56078737dbe7158049518892cf6bfb2
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8104-32-deb9
@@ -1464,97 +1564,6 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.4
dlHash: 0d18ef83593272f6196a41cc3abdc48dfe5e14372db75d71ea19fe35320c4e81
8.10.5:
viTags:
- Recommended
- base-4.14.2.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.5/docs/html/users_guide/8.10.5-notes.html
viSourceDL:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-src.tar.xz
dlSubdir: ghc-8.10.5
dlHash: f10941f16e4fbd98580ab5241b9271bb0851304560c4d5ca127e3b0e20e3076f
viPostRemove: *ghc-post-remove
viPreCompile: *ghc-pre-compile
viArch:
A_64:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8105-64-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-deb9-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 15e71325c3bdfe3804be0f84c2fc5c913d811322d19b0f4d4cff20f29cdd804d
'( >= 10 && < 11 )': &ghc-8105-64-deb10
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: bc623c20ca4c5c18e952071ba14aa0cfc5c94d34219bffaa615f7b491f376787
unknown_versioning: *ghc-8105-64-deb9
Linux_Ubuntu:
unknown_versioning: &ghc-8105-64-fedora
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-fedora27-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 73528ebfb219b50aa9042ee51a0a2bd764828d605f058404989d0b645752d210
'( >= 16 && < 19 )': *ghc-8105-64-deb9
Linux_Mint:
unknown_versioning: *ghc-8105-64-deb10
Linux_Fedora:
'( >= 27 && < 28 )': *ghc-8105-64-fedora
unknown_versioning: *ghc-8105-64-fedora
Linux_CentOS:
'( >= 7 && < 8 )': &ghc-8105-64-centos
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-centos7-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 4cdb259ec74d1408dab45dab20dcedc21690f39921c2ea4546486fb3e81f4fbd
unknown_versioning: *ghc-8105-64-centos
Linux_RedHat:
unknown_versioning: *ghc-8105-64-centos
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-alpine3.10-linux-integer-simple.tar.xz
dlSubdir: ghc-8.10.5-x86_64-unknown-linux
dlHash: f4d7cd9ed12a4b8592219c9a63a86db1a256a09fa9e6ed755a60afc57dc782e2
Linux_AmazonLinux:
unknown_versioning: *ghc-8105-64-centos
Linux_UnknownLinux:
unknown_versioning: *ghc-8105-64-fedora
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.10.5
dlHash: ef0f47eff8962d58fa447123636cf8ef31c1e5b2d0ae90177d3388861ddf4a22
# FreeBSD:
# unknown_versioning:
# dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-portbld-freebsd.tar.xz
# dlSubdir: ghc-8.10.5
# dlHash: c9776a2ccf9629b03e967206a507fcdcb6c5189800a626e9461ababf6733c357
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8105-32-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-i386-deb9-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 0ccb5b2c1222374874795c35410754dd650f649b774872abbea2a4ef21ac9c9d
unknown_versioning: *ghc-8105-32-deb9
Linux_Ubuntu:
unknown_versioning: *ghc-8105-32-deb9
Linux_Mint:
unknown_versioning: *ghc-8105-32-deb9
Linux_UnknownLinux:
unknown_versioning: *ghc-8105-32-deb9
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/8.10.5/ghc-8.10.5-i386-alpine-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 0e91abe61607f9375d4e252ee9c261e4856df396f60641bb1b880ab8a3a83ea7
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-aarch64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 9a085cd8a7f8e0ace21ac67dbf659a56fcf41564b48817ba42cd8a1aac7f0ddc
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 56170d1a8450e18b7eb9c23c94723da352815b27ec250bb23742a62f16dcab6c
9.0.1:
viTags:
- Latest
@@ -1615,6 +1624,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/9.0.1/ghc-9.0.1-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-9.0.1
dlHash: 9dbc06d8832cae5c9f86dd7b2db729b3748a47beb4fd4b1e62bb66119817c3c1
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/9.0.1/ghc-9.0.1-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-9.0.1-x86_64-unknown-mingw32
dlHash: 4f4ab118df01cbc7e7c510096deca0cb25025339a97730de0466416296202493
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-901-32-deb9
@@ -1705,6 +1719,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/9.2.1-alpha2/ghc-9.2.0.20210422-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-9.2.0.20210422
dlHash: 8884c059f2b76e4c4309ff6bd7a7dde37663f751fd26220e9a2bcabb4d69a401
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/9.2.1-alpha2/ghc-9.2.0.20210422-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-9.0.1-x86_64-unknown-mingw32
dlHash: 33f173b754d18f26bb27f52bb77a92fd22a48675daa2b43a1879bf01dddd7e8f
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-921-alpha2-32-deb9
@@ -1757,6 +1776,11 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-portbld-freebsd.tar.xz
dlSubdir:
dlHash: 33b7d37ea0688c93436eac9ec139d9967687875aa1fa13f2bb73bf05a9a59a1d
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-unknown-mingw32.zip
dlSubdir:
dlHash: 95f233efedb1ebf0e6db015fa2f55c1ed00b9938d207ec63c066f706fb4b6373
A_32:
Linux_UnknownLinux:
unknown_versioning:
@@ -1785,6 +1809,11 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-portbld-freebsd.tar.xz
dlHash: 2240842ab2ae7b955feb8b526aba1c7991248c803383107adf39990441294d2a
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-mingw32.zip
dlSubdir:
dlHash: 8889963ebef5e829d86329fdb59832c107efd117cf7862a605f2fe2d2360de1f
A_32:
Linux_Alpine:
unknown_versioning:
@@ -1816,6 +1845,11 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz
dlHash: f1e35151cca91541b0fb4bdb3ed18f3c348038eab751845ad19c11307d66c273
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-unknown-mingw32.zip
dlSubdir:
dlHash: 17778c3ade0482bc37f451eec326f8fce8fbe1f12b1d6aacb2e2b9e34786c054
A_32:
Linux_Alpine:
unknown_versioning:
@@ -1850,6 +1884,11 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
dlHash: a1e2db664ec00e42a1e071a4181f6476f6e0bad321f1ddc0cf27831119f4c6d4
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-x86_64-windows.zip
dlSubdir:
dlHash: 860fff2d39a82d1dc0ca924a77164d0988af49c2c5f45e15d615144122beb647
A_32:
Linux_UnknownLinux:
unknown_versioning: &cabal-3400-32
@@ -1888,6 +1927,10 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/x86_64-portbld-freebsd-ghcup-0.1.14.1
dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
Windows:
unknown_versioning:
dlUri: https://TODO
dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32:
@@ -1924,5 +1967,63 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.1.0/haskell-language-server-macOS-1.1.0.tar.gz
dlHash: 4e89b192e2f49637d772e974f2c17b16da067ecd5912575eaa542551de97681b
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/hls/1.1.0/haskell-language-server-Windows-1.1.0.tar.gz
dlHash: a1d3f451e64a041aa527a25da29e4716a2de6ae347cef4ef9312fc7611e168cc
Linux_Alpine:
unknown_versioning: *hls-64
Stack:
2.5.1:
viTags: []
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v251
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &stack-251-64
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz
dlHash: c83b6c93d6541c0bce2175085a04062020f4160a86116e20f3b343b562f2d1e8
dlSubdir:
RegexDir: "stack-.*"
Darwin:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz
dlHash: f4aedfa8fbe371f77286ee97ec5c3c553842e7ae15b2952a8b8442dccba04bf0
dlSubdir:
RegexDir: "stack-.*"
Windows:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-windows-x86_64.tar.gz
dlHash: 57150b422cfd42249f5e629d0eb678df6d95dabe486ced57e8298d300b940d41
dlSubdir:
RegexDir: "stack-.*"
Linux_Alpine:
unknown_versioning: *stack-251-64
2.7.1:
viTags:
- Recommended
- Latest
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &stack-64
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
dlSubdir:
RegexDir: "stack-.*"
Darwin:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-osx-x86_64.tar.gz
dlHash: 4248c6fbc87e8a2c06f39e867eb5ef28eae0d99470137cb415356c631c0dcbf2
dlSubdir:
RegexDir: "stack-.*"
Windows:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-windows-x86_64.tar.gz
dlHash: 8452f5fc9235620a84863f2f68e5f681c72d0d181cde50482f178a966ee0ceb9
dlSubdir:
RegexDir: "stack-.*"
Linux_Alpine:
unknown_versioning: *stack-64

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.15
version: 0.1.14.2
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020
@@ -19,7 +19,6 @@ extra-doc-files:
CHANGELOG.md
config.yaml
ghcup-0.0.4.yaml
ghcup-0.0.5.yaml
HACKING.md
README.md
RELEASING.md
@@ -44,7 +43,7 @@ flag internal-downloader
flag tar
description:
Use tar-bytestring instead of libarchive.
Use tar-bytestring instead of libarchive. This is always enabled on windows.
default: False
manual: True
@@ -76,20 +75,14 @@ library
autogen-modules: Paths_ghcup
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
@@ -125,14 +118,17 @@ library
, parsec ^>=3.1
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, process ^>=1.6.9.0
, regex-posix ^>=0.96
, resourcet ^>=1.2.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, split ^>=0.2.3.4
, streamly ^>=0.7.3
, streamly-bytestring ^>=0.1.2
, strict-base ^>=0.4
, string-interpolate >=0.2.0.0 && <0.4
, template-haskell >=2.7 && <2.18
, template-haskell >=2.7 && <2.17
, temporary ^>=1.3
, text ^>=1.2.4.0
, time ^>=1.9.3
@@ -145,7 +141,7 @@ library
, versions ^>=4.0.1
, word8 ^>=0.1.3
, yaml ^>=0.11.4.0
, zip ^>=1.7.1
, zip ^>=1.7.0
, zlib ^>=0.6.2.2
if (flag(internal-downloader) && !os(windows))
@@ -154,7 +150,7 @@ library
build-depends:
, HsOpenSSL >=0.11.4.18
, http-io-streams >=0.1.2.0
, io-streams >=1.5.2.1
, io-streams >=1.5
, terminal-progress-bar >=0.4.1
if (flag(tar) || os(windows))
@@ -167,18 +163,14 @@ library
if os(windows)
cpp-options: -DIS_WINDOWS
other-modules: GHCup.Utils.File.Windows
build-depends:
, bzlib
, process ^>=1.6.11.0
, retry ^>=0.8.1.2
, Win32 ^>=2.10
build-depends: bzlib
else
other-modules: GHCup.Utils.File.Posix
build-depends:
, bz2 >=0.5.0.5 && <1.1
bz2 >=0.5.0.5 && <1.1
, hpath-posix ^>=0.13.3
, process ^>=1.6.9
, streamly-posix ^>=0.1.0.0
, unix ^>=2.7
, unix-bytestring ^>=0.3.7.3
@@ -193,7 +185,6 @@ executable ghcup
default-extensions:
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
RecordWildCards
ScopedTypeVariables
@@ -206,6 +197,7 @@ executable ghcup
-fwarn-incomplete-record-updates -threaded
build-depends:
, aeson >=1.4 && <1.6
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
@@ -222,7 +214,7 @@ executable ghcup
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, string-interpolate >=0.2.0.0 && <0.4
, template-haskell >=2.7 && <2.18
, template-haskell >=2.7 && <2.17
, text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
@@ -235,13 +227,9 @@ executable ghcup
cpp-options: -DBRICK
other-modules: BrickMain
build-depends:
, brick >=0.5 && <0.62
, transformers ^>=0.5
, vector ^>=0.12
, vty >=5.28.2 && <5.34
if os(windows)
cpp-options: -DIS_WINDOWS
, brick >=0.5 && <0.62
, vector ^>=0.12
, vty >=5.28.2 && <5.34
if (flag(tar) || os(windows))
cpp-options: -DTAR
@@ -255,26 +243,20 @@ executable ghcup-gen
other-modules: Validate
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
build-depends:
, aeson >=1.4 && <1.6
, aeson-pretty ^>=0.8.8
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
@@ -294,6 +276,7 @@ executable ghcup-gen
, text ^>=1.2.4.0
, transformers ^>=0.5
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, versions ^>=4.0.1
, yaml ^>=0.11.4.0
@@ -333,7 +316,7 @@ test-suite ghcup-test
, generic-arbitrary ^>=0.1.0
, ghcup
, hspec ^>=2.7.10
, hspec-golden-aeson ^>=0.9
, hspec-golden-aeson >=0.9 && <0.10
, QuickCheck ^>=2.14.1
, quickcheck-arbitrary-adt ^>=0.3.1.0
, text ^>=1.2.4.0

File diff suppressed because it is too large Load Diff

View File

@@ -1,11 +1,15 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup
@@ -108,6 +112,7 @@ installGHCBindist :: ( MonadFail m
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> PlatformRequest -- ^ the platform to install on
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -123,22 +128,20 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver = do
AppState { dirs , settings } <- lift ask
installGHCBindist dlinfo ver pfreq = do
let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing
dl <- liftE $ downloadCached dlinfo Nothing
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
toolchainSanityChecks
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver pfreq
liftE $ postGHCInstall tver
@@ -167,6 +170,7 @@ installPackedGHC :: ( MonadMask m
-> Maybe TarDir -- ^ Subdir of the archive
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts
'[ BuildFailed
, UnknownArchive
@@ -175,13 +179,11 @@ installPackedGHC :: ( MonadMask m
, ArchiveResult
#endif
] m ()
installPackedGHC dl msubdir inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask
installPackedGHC dl msubdir inst ver pfreq@PlatformRequest{..} = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
@@ -190,7 +192,7 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
(installUnpackedGHC workdir inst ver pfreq)
-- | Install an unpacked GHC distribution. This only deals with the GHC
@@ -203,36 +205,30 @@ installUnpackedGHC :: ( MonadReader AppState m
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts '[ProcessError] m ()
#if defined(IS_WINDOWS)
installUnpackedGHC path inst _ = do
installUnpackedGHC path inst _ _ = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
-- windows bindists are relocatable and don't need
-- to run configure
liftIO $ copyDirectoryRecursive path inst
#else
installUnpackedGHC path inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
installUnpackedGHC path inst ver PlatformRequest{..} = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
#if defined(IS_WINDOWS)
: "--enable-tarballs-autodownload"
#endif
: alpineArgs
)
("./configure" : ("--prefix=" <> inst) : alpineArgs)
(Just path)
"ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
pure ()
where
alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
#endif
@@ -250,7 +246,9 @@ installGHCBin :: ( MonadFail m
, MonadIO m
, MonadUnliftIO m
)
=> Version -- ^ the version to install
=> GHCupDownloads -- ^ the download info to look up the tarball from
-> Version -- ^ the version to install
-> PlatformRequest -- ^ the platform to install on
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -266,11 +264,9 @@ installGHCBin :: ( MonadFail m
]
m
()
installGHCBin ver = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls
installGHCBindist dlinfo ver
installGHCBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
installGHCBindist dlinfo ver pfreq
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@@ -286,6 +282,7 @@ installCabalBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -301,29 +298,27 @@ installCabalBindist :: ( MonadMask m
]
m
()
installCabalBindist dlinfo ver = do
installCabalBindist dlinfo ver PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
AppState { dirs = dirs@Dirs {..}
, pfreq = PlatformRequest {..}
, settings } <- lift ask
AppState {dirs = Dirs {..}} <- lift ask
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
$ pathIsSymbolicLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
-- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@@ -365,7 +360,9 @@ installCabalBin :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Version
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -381,11 +378,9 @@ installCabalBin :: ( MonadMask m
]
m
()
installCabalBin ver = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls
installCabalBindist dlinfo ver
installCabalBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
installCabalBindist dlinfo ver pfreq
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@@ -401,6 +396,7 @@ installHLSBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -416,23 +412,21 @@ installHLSBindist :: ( MonadMask m
]
m
()
installHLSBindist dlinfo ver = do
installHLSBindist dlinfo ver PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
AppState { dirs = dirs@Dirs {..}
, pfreq = PlatformRequest {..}
, settings } <- lift ask
AppState {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@@ -489,7 +483,9 @@ installHLSBin :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Version
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -505,11 +501,9 @@ installHLSBin :: ( MonadMask m
]
m
()
installHLSBin ver = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls
installHLSBindist dlinfo ver
installHLSBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo HLS ver pfreq bDls
installHLSBindist dlinfo ver pfreq
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
@@ -524,7 +518,9 @@ installStackBin :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Version
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -540,10 +536,9 @@ installStackBin :: ( MonadMask m
]
m
()
installStackBin ver = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls
installStackBindist dlinfo ver
installStackBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo Stack ver pfreq bDls
installStackBindist dlinfo ver pfreq
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
@@ -559,6 +554,7 @@ installStackBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -574,24 +570,21 @@ installStackBindist :: ( MonadMask m
]
m
()
installStackBindist dlinfo ver = do
installStackBindist dlinfo ver PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
AppState { dirs = dirs@Dirs {..}
, pfreq = PlatformRequest {..}
, settings
} <- lift ask
AppState {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
-- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@@ -644,8 +637,6 @@ setGHC :: ( MonadReader AppState m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> SetGHC
@@ -687,7 +678,10 @@ setGHC ver sghc = do
let fullF = binDir </> targetFile <> exeExt
fileWithExt = file <> exeExt
destL <- lift $ ghcLinkDestination fileWithExt ver
lift $ createLink destL fullF
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
lift $ $(logDebug) [i|ln -s #{destL} #{fullF}|]
liftIO $ createFileLink destL fullF
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
@@ -711,29 +705,15 @@ setGHC ver sghc = do
let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeDirectoryLink fullF
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
liftIO
#if defined(IS_WINDOWS)
-- On windows we need to be more permissive
-- in case symlinks can't be created, be just
-- give up here. This symlink isn't strictly necessary.
$ hideError permissionErrorType
$ hideError illegalOperationErrorType
#endif
$ createDirectoryLink targetF fullF
liftIO $ createDirectoryLink targetF fullF
_ -> pure ()
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: ( MonadMask m
, MonadReader AppState m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadUnliftIO m)
setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
@@ -749,9 +729,15 @@ setCabal ver = do
let cabalbin = binDir </> "cabal" <> exeExt
-- create link
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{cabalbin}|]
liftIO $ hideError doesNotExistErrorType $ removeFile
cabalbin
-- create symlink
let destL = targetFile
lift $ createLink destL cabalbin
lift $ $(logDebug) [i|ln -s #{destL} #{cabalbin}|]
liftIO $ createFileLink destL cabalbin
pure ()
@@ -765,8 +751,6 @@ setHLS :: ( MonadCatch m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
@@ -779,7 +763,7 @@ setHLS ver = do
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{binDir </> f}|]
liftIO $ rmLink (binDir </> f)
liftIO $ removeFile (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
@@ -788,26 +772,28 @@ setHLS ver = do
forM_ bins $ \f -> do
let destL = f
let target = (<> exeExt) . head . splitOn "~" $ f
lift $ createLink destL (binDir </> target)
lift $ $(logDebug) [i|rm -f #{binDir </> target}|]
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> target)
lift $ $(logDebug) [i|ln -s #{destL} #{binDir </> target}|]
liftIO $ createFileLink destL (binDir </> target)
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
lift $ createLink destL wrapper
lift $ $(logDebug) [i|rm -f #{wrapper}|]
liftIO $ hideError doesNotExistErrorType $ removeFile wrapper
lift $ $(logDebug) [i|ln -s #{destL} #{wrapper}|]
liftIO $ createFileLink destL wrapper
pure ()
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: ( MonadMask m
, MonadReader AppState m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadUnliftIO m
)
setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setStack ver = do
@@ -823,7 +809,14 @@ setStack ver = do
let stackbin = binDir </> "stack" <> exeExt
lift $ createLink targetFile stackbin
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{stackbin}|]
liftIO $ hideError doesNotExistErrorType $ removeFile
stackbin
-- create symlink
lift $ $(logDebug) [i|ln -s #{targetFile} #{stackbin}|]
liftIO $ createFileLink targetFile stackbin
pure ()
@@ -872,10 +865,12 @@ listVersions :: ( MonadCatch m
, MonadIO m
, MonadReader AppState m
)
=> Maybe Tool
=> GHCupDownloads
-> Maybe Tool
-> Maybe ListCriteria
-> PlatformRequest
-> m [ListResult]
listVersions lt' criteria = do
listVersions av lt' criteria pfreq = do
-- some annoying work to avoid too much repeated IO
cSet <- cabalSet
cabals <- getInstalledCabals' cSet
@@ -889,9 +884,8 @@ listVersions lt' criteria = do
go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of
Just t -> do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-- get versions from GHCupDownloads
let avTools = availableToolVersions dls t
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
case t of
@@ -1053,71 +1047,67 @@ listVersions lt' criteria = do
-> [Either FilePath Version]
-> (Version, [Tag])
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq dls
let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq dls
let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet
pure ListResult { lVer = v
, lTag = tags
, lCross = Nothing
, lTool = t
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq dls
let lSet = hlsSet' == Just v
let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
Stack -> do
let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq dls
let lSet = stackSet' == Just v
let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet
pure ListResult { lVer = v
, lTag = tags
, lCross = Nothing
, lTool = t
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
let lSet = hlsSet' == Just v
let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
Stack -> do
let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq av
let lSet = stackSet' == Just v
let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
filter' :: [ListResult] -> [ListResult]
@@ -1144,8 +1134,6 @@ rmGHCVer :: ( MonadReader AppState m
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
@@ -1169,7 +1157,7 @@ rmGHCVer ver = do
-- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
liftIO $ rmPath dir
liftIO $ removeDirectoryRecursive dir
v' <-
handle
@@ -1183,20 +1171,12 @@ rmGHCVer ver = do
liftIO
$ hideError doesNotExistErrorType
$ rmFile (baseDir </> "share")
$ removeFile (baseDir </> "share")
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version).
rmCabalVer :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
@@ -1207,26 +1187,19 @@ rmCabalVer ver = do
AppState {dirs = Dirs {..}} <- lift ask
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> cabalFile)
when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> liftIO $ rmLink (binDir </> "cabal" <> exeExt)
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
(binDir </> "cabal" <> exeExt)
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
rmHLSVer :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmHLSVer ver = do
@@ -1237,15 +1210,15 @@ rmHLSVer ver = do
AppState {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
forM_ bins $ \f -> liftIO $ removeFile (binDir </> f)
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
let fullF = binDir </> f
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm #{fullF}|]
liftIO $ rmLink fullF
liftIO $ removeFile fullF
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
@@ -1255,15 +1228,7 @@ rmHLSVer ver = do
-- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version).
rmStackVer :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
rmStackVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmStackVer ver = do
@@ -1274,13 +1239,14 @@ rmStackVer ver = do
AppState {dirs = Dirs {..}} <- lift ask
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> stackFile)
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver
Nothing -> liftIO $ rmLink (binDir </> "stack" <> exeExt)
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
(binDir </> "stack" <> exeExt)
@@ -1289,7 +1255,7 @@ rmStackVer ver = do
------------------
getDebugInfo :: (Alternative m, MonadFail m, MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m)
getDebugInfo :: (MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m
@@ -1323,13 +1289,14 @@ compileGHC :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Either GHCTargetVersion GitBranch -- ^ version to install
-> Maybe Version -- ^ overwrite version
=> GHCupDownloads
-> Either GHCTargetVersion GitBranch -- ^ version to install
-> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe FilePath -- ^ build config
-> Maybe FilePath -- ^ patch directory
-> [Text] -- ^ additional args to ./configure
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -1348,12 +1315,8 @@ compileGHC :: ( MonadMask m
]
m
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
= do
AppState { pfreq = PlatformRequest {..}
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
, settings
, dirs } <- lift ask
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
Left tver -> do
@@ -1363,12 +1326,12 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached settings dirs dlInfo Nothing
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
@@ -1402,21 +1365,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
lEM $ execLogged "sh" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" Nothing
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" Nothing
CapturedProcess {..} <- lift $ makeOut
CapturedProcess {..} <- liftIO $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
void $ lift $ darwinNotarization _rPlatform tmpUnpack
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov
alreadyInstalled <- lift $ ghcInstalled installVer
alreadyInstalled <- lift $ ghcInstalled tver
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
when alreadyInstalled $ do
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
@@ -1424,11 +1384,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
"...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
ghcdir <- lift $ ghcupGHCDir installVer
ghcdir <- lift $ ghcupGHCDir tver
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver))
(bindist, bmk) <- liftE $ runBuildAction
tmpUnpack
@@ -1446,6 +1406,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
(Just $ RegexDir "ghc-.*")
ghcdir
(tver ^. tvVersion)
pfreq
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
@@ -1490,7 +1451,7 @@ HADDOCK_DOCS = YES|]
lift $ $(logInfo) [i|configuring build|]
liftE checkBuildConfig
AppState { dirs = Dirs {..}, pfreq } <- lift ask
AppState { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
@@ -1507,9 +1468,6 @@ HADDOCK_DOCS = YES|]
("./configure" : maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
#if defined(IS_WINDOWS)
++ ["--enable-tarballs-autodownload"]
#endif
++ fmap T.unpack aargs
)
(Just workdir)
@@ -1523,9 +1481,6 @@ HADDOCK_DOCS = YES|]
++ maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
#if defined(IS_WINDOWS)
++ ["--enable-tarballs-autodownload"]
#endif
++ fmap T.unpack aargs
)
(Just workdir)
@@ -1561,7 +1516,7 @@ HADDOCK_DOCS = YES|]
. SHA256.hashlazy
$ c
cTime <- liftIO getCurrentTime
let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
let tarName = [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
@@ -1612,9 +1567,11 @@ upgradeGHCup :: ( MonadMask m
, MonadIO m
, MonadUnliftIO m
)
=> Maybe FilePath -- ^ full file destination to write ghcup into
=> GHCupDownloads
-> Maybe FilePath -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> PlatformRequest
-> Excepts
'[ CopyError
, DigestError
@@ -1624,24 +1581,21 @@ upgradeGHCup :: ( MonadMask m
]
m
Version
upgradeGHCup mtarget force = do
AppState { dirs = Dirs {..}
, pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
, settings } <- lift ask
upgradeGHCup dls mtarget force pfreq = do
AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir
let fn = "ghcup" <> exeExt
p <- liftE $ download settings dli tmp (Just fn)
p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' destDir
lift $ $(logDebug) [i|rm -f #{destFile}|]
liftIO $ hideError NoSuchThing $ rmFile destFile
liftIO $ hideError NoSuchThing $ removeFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
@@ -1670,8 +1624,6 @@ postGHCInstall :: ( MonadReader AppState m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()

View File

@@ -36,7 +36,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.Dirs
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
@@ -53,8 +53,8 @@ import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.Bifunctor
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( CI )
#endif
import Data.List.Extra
@@ -66,7 +66,6 @@ import Data.Time.Clock.POSIX
import Data.Time.Format
#endif
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
@@ -81,7 +80,6 @@ import System.IO.Error
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
@@ -112,26 +110,26 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> Settings
-> Dirs
=> URLSource
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF settings@Settings{ urlSource } dirs = do
getDownloadsF urlSource = do
case urlSource of
GHCupURL -> liftE $ getBase dirs settings
GHCupURL -> liftE getBase
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE $ getBase dirs settings
base <- liftE getBase
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
base <- liftE $ getBase dirs settings
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
base <- liftE getBase
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
@@ -140,19 +138,18 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-> GHCupInfo -- ^ extension overwriting the base
-> GHCupInfo
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) =
let new = M.mapWithKey (\k a -> case M.lookup k ext of
Just a' -> M.union a' a
Nothing -> a
) base
newGlobalTools = M.union base2 ext2
in GHCupInfo tr newDownloads newGlobalTools
) base
in GHCupInfo tr new
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache Dirs {..} = do
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
@@ -165,14 +162,12 @@ readFromCache Dirs {..} = do
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Settings
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase dirs@Dirs{..} Settings{ downloader } =
handleIO (\_ -> readFromCache dirs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase =
handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache dirs)
(\(DownloadFailed _) -> readFromCache)
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
where
@@ -190,6 +185,7 @@ getBase dirs@Dirs{..} Settings{ downloader } =
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, MonadReader AppState m1
)
=> URI
-> Excepts
@@ -204,6 +200,7 @@ getBase dirs@Dirs{..} Settings{ downloader } =
m1
L.ByteString
smartDl uri' = do
AppState {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri'
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
e <- liftIO $ doesFileExist json_file
@@ -238,12 +235,12 @@ getBase dirs@Dirs{..} Settings{ downloader } =
where
dlWithMod modTime json_file = do
bs <- liftE $ downloadBS downloader uri'
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS downloader uri'
liftIO $ hideError doesNotExistErrorType $ rmFile json_file
bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ removeFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs
@@ -323,16 +320,16 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
--
-- The file must not exist.
download :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Settings
-> DownloadInfo
=> DownloadInfo
-> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
download settings@Settings{ downloader } dli dest mfn
download dli dest mfn
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = cp
@@ -357,20 +354,20 @@ download settings@Settings{ downloader } dli dest mfn
-- download
flip onException
(liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
(liftIO $ hideError doesNotExistErrorType $ removeFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
liftIO (hideError doesNotExistErrorType $ rmFile destFile)
liftIO (hideError doesNotExistErrorType $ removeFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
case downloader of
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl"
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
Wget -> do
o' <- liftIO getWgetOpts
liftE $ lEM @_ @'[ProcessError] $ exec "wget"
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget"
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
@@ -378,7 +375,7 @@ download settings@Settings{ downloader } dli dest mfn
liftE $ downloadToFile https host fullPath port destFile
#endif
liftE $ checkDigest settings dli destFile
liftE $ checkDigest dli destFile
pure destFile
-- Manage to find a file we can write the body into.
@@ -396,40 +393,27 @@ downloadCached :: ( MonadMask m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
, MonadReader AppState m
)
=> Settings
-> Dirs
-> DownloadInfo
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached settings@Settings{ cache } dirs dli mfn = do
downloadCached dli mfn = do
cache <- lift getCache
case cache of
True -> downloadCached' settings dirs dli mfn
True -> do
AppState {dirs = Dirs {..}} <- lift ask
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure cachfile
| otherwise -> liftE $ download dli cacheDir mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download settings dli tmp mfn
downloadCached' :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
)
=> Settings
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached' settings Dirs{..} dli mfn = do
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest settings dli cachfile
pure cachfile
| otherwise -> liftE $ download settings dli cacheDir mfn
liftE $ download dli tmp mfn
@@ -442,9 +426,8 @@ downloadCached' settings Dirs{..} dli mfn = do
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
=> Downloader
-> URI
downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
@@ -456,7 +439,7 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
]
m
L.ByteString
downloadBS downloader uri'
downloadBS uri'
| scheme == "https"
= dl True
| scheme == "http"
@@ -476,12 +459,12 @@ downloadBS downloader uri'
dl _ = do
#endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
case downloader of
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
let exe = "curl"
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
@@ -489,7 +472,7 @@ downloadBS downloader uri'
o' <- liftIO getWgetOpts
let exe = "wget"
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
@@ -500,13 +483,12 @@ downloadBS downloader uri'
#endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Settings
-> DownloadInfo
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo
-> FilePath
-> Excepts '[DigestError] m ()
checkDigest Settings{ noVerify } dli file = do
let verify = not noVerify
checkDigest dli file = do
verify <- lift ask <&> (not . noVerify . settings)
when verify $ do
let p' = takeFileName file
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
@@ -531,8 +513,3 @@ getWgetOpts =
Just r -> pure $ splitOn " " r
Nothing -> pure []
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False

View File

@@ -44,7 +44,6 @@ import Prelude hiding ( abs
import System.Info
import System.Directory
import System.OsRelease
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.Text as T
@@ -58,7 +57,7 @@ import qualified Data.Text.IO as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m
@@ -83,7 +82,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m)
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
m
@@ -109,25 +108,26 @@ getPlatform = do
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{prettyShow pfr}|]
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
where
getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
getDarwinVersion = lift $ fmap _stdOut $ executeOut "sw_vers"
getFreeBSDVersion =
liftIO $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut "sw_vers"
["-productVersion"]
Nothing
getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
-- TODO: don't do alternative on IO, because it hides bugs
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
[ liftIO try_os_release
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, liftIO try_redhat_release
, liftIO try_debian_version
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
@@ -163,10 +163,9 @@ getLinuxDistro = do
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
try_lsb_release_cmd :: (MonadFail m, MonadIO m)
=> m (Text, Maybe Text)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _) <- liftIO $ findExecutable lsb_release_cmd
(Just _) <- findExecutable lsb_release_cmd
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)

View File

@@ -20,20 +20,16 @@ module GHCup.Types
)
where
import Control.Applicative
import Control.Monad.Logger
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
#endif
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Text as T
import qualified GHC.Generics as GHC
@@ -56,7 +52,6 @@ data Key = KEsc | KChar Char | KBS | KEnter
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
}
deriving (Show, GHC.Generic)
@@ -105,9 +100,6 @@ data Tool = GHC
| Stack
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
-- | All necessary information of a tool version, including
-- source download and per-architecture downloads.
@@ -315,8 +307,6 @@ data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
} deriving (Show)
data Settings = Settings
@@ -447,16 +437,3 @@ instance Pretty Versioning where
instance Pretty Version where
pPrint = text . T.unpack . prettyVer
instance (Monad m, Alternative m) => Alternative (LoggingT m) where
empty = Trans.lift empty
{-# INLINE empty #-}
m <|> n = LoggingT $ \ r -> runLoggingT m r <|> runLoggingT n r
{-# INLINE (<|>) #-}
instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d

View File

@@ -44,16 +44,23 @@ import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
instance ToJSON Tag where
toJSON Latest = String "Latest"
@@ -190,12 +197,6 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSONKey GlobalTool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance FromJSONKey GlobalTool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p
toJSON (RegexDir r) = object ["RegexDir" .= r]
@@ -305,14 +306,3 @@ instance FromJSONKey (Maybe VersionRange) where
just t = case MP.parse versionRangeP "" t of
Right x -> pure $ Just x
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings

View File

@@ -26,9 +26,6 @@ module GHCup.Utils
where
#if defined(IS_WINDOWS)
import GHCup.Download
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
@@ -51,11 +48,6 @@ import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
@@ -66,6 +58,7 @@ import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
@@ -73,11 +66,7 @@ import Safe
import System.Directory hiding ( findFiles )
import System.FilePath
import System.IO.Error
#if defined(IS_WINDOWS)
import System.Win32.Console
import System.Win32.File hiding ( copyFile )
import System.Win32.Types
#endif
import System.IO.Unsafe ( unsafeInterleaveIO )
import Text.Regex.Posix
import URI.ByteString
@@ -132,7 +121,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
-- | Removes the set ghc version for the given target, if any.
@@ -152,11 +141,11 @@ rmPlain target = do
forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
-- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
liftIO $ hideError doesNotExistErrorType $ removeFile hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -179,7 +168,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
@@ -216,27 +205,27 @@ ghcSet mtarget = do
-- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
link <- liftIO $ getLinkTarget ghcBin
link <- liftIO $ getSymbolicLinkTarget ghcBin
Just <$> ghcLinkVersion link
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
where
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
where
parser =
(do
_ <- parseUntil1 ghcSubPath
_ <- ghcSubPath
r <- parseUntil1 pathSep
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* pathSep
<* MP.takeRest
<* MP.eof
ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
parser =
(do
_ <- parseUntil1 ghcSubPath
_ <- ghcSubPath
r <- parseUntil1 pathSep
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* pathSep
<* MP.takeRest
<* MP.eof
ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
@@ -265,7 +254,7 @@ getInstalledCabals' cs = do
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
vs <- forM bins $ \f -> case fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "cabal-" $ f of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
@@ -284,7 +273,7 @@ cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, Mon
cabalSet = do
AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> "cabal" <> exeExt
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsLink cabalbin
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsSymbolicLink cabalbin
if
| b -> do
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@@ -292,20 +281,20 @@ cabalSet = do
if broken
then pure Nothing
else do
link <- liftIO $ getLinkTarget cabalbin
link <- liftIO $ getSymbolicLinkTarget cabalbin
case linkVersion link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
pure Nothing
| otherwise -> do -- legacy behavior
mc <- handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd isNewLine . BL.toStrict . _stdOut $ c
let reportedVer = fst . B.spanEnd (== _lf) . BL.toStrict . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
@@ -315,7 +304,7 @@ cabalSet = do
-- because of:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
parser
= MP.try (stripAbsolutePath *> cabalParse)
@@ -349,7 +338,7 @@ getInstalledHLSs = do
)
forM bins $ \f ->
case
version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "haskell-language-server-wrapper-" $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
@@ -368,7 +357,9 @@ getInstalledStacks = do
([s|^stack-.*$|] :: ByteString)
)
forM bins $ \f ->
case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
case
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "stack-" $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
@@ -385,27 +376,14 @@ stackSet = do
if broken
then pure Nothing
else do
link <- liftIO $ getLinkTarget stackBin
link <- liftIO $ getSymbolicLinkTarget stackBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
where
parser
= MP.try (stripAbsolutePath *> cabalParse)
<|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse
-- parses the version of "stack-2.7.1" -> "2.7.1"
cabalParse = MP.chunk "stack-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
parser =
MP.chunk "stack-" *> version'
-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
@@ -432,27 +410,14 @@ hlsSet = do
if broken
then pure Nothing
else do
link <- liftIO $ getLinkTarget hlsBin
link <- liftIO $ getSymbolicLinkTarget hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
where
parser
= MP.try (stripAbsolutePath *> cabalParse)
<|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse
-- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
-- | Return the GHC versions the currently selected HLS supports.
@@ -535,7 +500,7 @@ hlsSymlinks = do
)
filterM
( liftIO
. pathIsLink
. pathIsSymbolicLink
. (binDir </>)
)
oldSyms
@@ -761,6 +726,11 @@ getDownloader = ask <&> downloader . settings
-------------
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
--
@@ -840,20 +810,19 @@ make args workdir = do
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake args workdir "ghc-make" Nothing
makeOut :: (MonadReader AppState m, MonadIO m)
=> [String]
makeOut :: [String]
-> Maybe FilePath
-> m CapturedProcess
-> IO CapturedProcess
makeOut args workdir = do
spaths <- liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
let mymake = if has_gmake then "gmake" else "make"
executeOut mymake args workdir
liftIO $ executeOut mymake args workdir
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m)
applyPatches :: (MonadLogger m, MonadIO m)
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
@@ -862,7 +831,7 @@ applyPatches pdir ddir = do
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
fmap (either (const Nothing) Just)
(exec
(liftIO $ exec
"patch"
["-p1", "-i", patch']
(Just ddir)
@@ -871,10 +840,7 @@ applyPatches pdir ddir = do
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: (MonadReader AppState m, MonadIO m)
=> Platform
-> FilePath
-> m (Either ProcessError ())
darwinNotarization :: Platform -> FilePath -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec
"xattr"
["-r", "-d", "com.apple.quarantine", path]
@@ -903,11 +869,11 @@ runBuildAction bdir instdir action = do
AppState { settings = Settings {..} } <- lift ask
let exAction = do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ rmPath dir
liftIO $ hideError doesNotExistErrorType $ removeDirectoryRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ rmPath bdir
$ removeDirectoryRecursive bdir
v <-
flip onException exAction
$ catchAllE
@@ -916,10 +882,90 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es)
) action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ removeDirectoryRecursive
bdir
pure v
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirectoryIfMissing True
$ p
where
isSymlinkDir e = do
ft <- pathIsSymbolicLink p
case ft of
True -> do
rp <- canonicalizePath p
rft <- doesDirectoryExist rp
case rft of
True -> pure ()
_ -> throwIO e
_ -> throwIO e
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
dest = targetDir </> srcFile
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
files' <- recurseDirectories (dirs' ++ dirs)
return (files ++ files')
where
collect files dirs' [] = return (reverse files
,reverse dirs')
collect files dirs' (entry:entries) | ignore entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist (topdir </> dirEntry)
if isDirectory
then collect files (dirEntry:dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
@@ -933,6 +979,15 @@ getVersionInfo v' tool =
)
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | The file extension for executables.
exeExt :: String
#if defined(IS_WINDOWS)
@@ -941,150 +996,3 @@ exeExt = ".exe"
exeExt = ""
#endif
-- | The file extension for executables.
exeExt' :: ByteString
#if defined(IS_WINDOWS)
exeExt' = ".exe"
#else
exeExt' = ""
#endif
-- | Enables ANSI support on windows, does nothing on unix.
--
-- Returns 'Left str' on errors and 'Right bool' on success, where
-- 'bool' markes whether ansi support was already enabled.
--
-- This function never crashes.
--
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
enableAnsiSupport :: IO (Either String Bool)
#if defined(IS_WINDOWS)
enableAnsiSupport = handleIO (pure . Left . displayException) $ do
-- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
-- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
-- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
m <- getConsoleMode h
-- VT processing not already enabled?
if ((m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING) == 0)
-- https://docs.microsoft.com/en-us/windows/console/setconsolemode
then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
>> pure (Right False)
else pure (Right True)
#else
enableAnsiSupport = pure (Right True)
#endif
-- | On unix, we can use symlinks, so we just get the
-- symbolic link target.
--
-- On windows, we have to emulate symlinks via shims,
-- see 'createLink'.
getLinkTarget :: FilePath -> IO FilePath
getLinkTarget fp = do
#if defined(IS_WINDOWS)
content <- readFile (dropExtension fp <.> "shim")
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
pure $ stripNewline $ dropPrefix "path = " p
#else
getSymbolicLinkTarget fp
#endif
-- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool
#if defined(IS_WINDOWS)
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
#else
pathIsLink = pathIsSymbolicLink
#endif
rmLink :: FilePath -> IO ()
#if defined(IS_WINDOWS)
rmLink fp = do
hideError doesNotExistErrorType . liftIO . rmFile $ fp
hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim")
#else
rmLink = hideError doesNotExistErrorType . liftIO . rmFile
#endif
-- | Creates a symbolic link on unix and a fake symlink on windows for
-- executables, which:
-- 1. is a shim exe
-- 2. has a corresponding .shim file in the same directory that
-- contains the target
--
-- This overwrites previously existing files.
--
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadUnliftIO m
, MonadFail m
)
=> FilePath -- ^ path to the target executable
-> FilePath -- ^ path to be created
-> m ()
createLink link exe = do
#if defined(IS_WINDOWS)
AppState { dirs } <- ask
let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute.
-- If link is relative, it's relative to the target exe.
-- Note that (</>) drops lhs when rhs is absolute.
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
$(logDebug) [i|rm -f #{exe}|]
liftIO $ rmLink exe
$(logDebug) [i|ln -s #{fullLink} #{exe}|]
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) [i|rm -f #{exe}|]
liftIO $ hideError doesNotExistErrorType $ rmFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do
#if defined(IS_WINDOWS)
AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe")
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure ()
#else
pure ()
#endif

View File

@@ -1,4 +0,0 @@
module GHCup.Utils where
getLinkTarget :: FilePath -> IO FilePath
pathIsLink :: FilePath -> IO Bool

View File

@@ -17,7 +17,6 @@ Portability : portable
-}
module GHCup.Utils.Dirs
( getDirs
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
, ghcupGHCBaseDir
@@ -48,9 +47,7 @@ import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
#if !defined(IS_WINDOWS)
import System.Directory
#endif
import System.Directory
import System.DiskSpace
import System.Environment
import System.FilePath
@@ -75,10 +72,6 @@ import Control.Concurrent (threadDelay)
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO FilePath
ghcupBaseDir = do
#if defined(IS_WINDOWS)
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
#else
xdg <- useXDG
if xdg
then do
@@ -93,7 +86,6 @@ ghcupBaseDir = do
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
-- | ~/.ghcup by default
@@ -102,9 +94,6 @@ ghcupBaseDir = do
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO FilePath
ghcupConfigDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir
#else
xdg <- useXDG
if xdg
then do
@@ -119,7 +108,6 @@ ghcupConfigDir = do
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@@ -127,9 +115,6 @@ ghcupConfigDir = do
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO FilePath
ghcupBinDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "bin")
#else
xdg <- useXDG
if xdg
then do
@@ -139,7 +124,6 @@ ghcupBinDir = do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
#endif
-- | Defaults to '~/.ghcup/cache'.
@@ -148,9 +132,6 @@ ghcupBinDir = do
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO FilePath
ghcupCacheDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "cache")
#else
xdg <- useXDG
if xdg
then do
@@ -161,7 +142,6 @@ ghcupCacheDir = do
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
#endif
-- | Defaults to '~/.ghcup/logs'.
@@ -170,9 +150,6 @@ ghcupCacheDir = do
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO FilePath
ghcupLogsDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "logs")
#else
xdg <- useXDG
if xdg
then do
@@ -183,7 +160,6 @@ ghcupLogsDir = do
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
#endif
getDirs :: IO Dirs
@@ -266,7 +242,7 @@ mkGhcupTmpDir = do
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) removeDirectoryRecursive)
@@ -276,10 +252,8 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
--------------
#if !defined(IS_WINDOWS)
useXDG :: IO Bool
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
#endif
relativeSymlink :: FilePath -- ^ the path in which to create the symlink

View File

@@ -8,6 +8,7 @@ module GHCup.Utils.File.Common where
import GHCup.Utils.Prelude
import Control.Exception
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Maybe
@@ -16,6 +17,7 @@ import GHC.IO.Exception
import Optics hiding ((<|), (|>))
import System.Directory
import System.FilePath
import System.IO.Error
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
@@ -104,3 +106,17 @@ findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
try (pathIsSymbolicLink fp) >>= \case
Right True -> do
let symDir = takeDirectory fp
tfp <- getSymbolicLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(symDir </> tfp)
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e

View File

@@ -42,7 +42,6 @@ import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions
import System.IO.Error
import System.FilePath
import System.Directory
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
@@ -64,12 +63,11 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
=> FilePath -- ^ command as filename, e.g. 'ls'
executeOut :: FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess
executeOut path args chdir = liftIO $ captureOutStreams $ do
-> IO CapturedProcess
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile path True args Nothing
@@ -318,13 +316,12 @@ createRegularFileFd fm dest =
-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
=> String -- ^ thing to execute
exec :: String -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
exec exe args chdir env = liftIO $ do
-> IO (Either ProcessError ())
exec exe args chdir env = do
pid <- SPP.forkProcess $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
@@ -369,18 +366,3 @@ newFilePerms =
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
try (pathIsSymbolicLink fp) >>= \case
Right True -> do
let symDir = takeDirectory fp
tfp <- getSymbolicLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(symDir </> tfp)
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e

View File

@@ -15,8 +15,6 @@ Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Windows where
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
import GHCup.Types
@@ -25,12 +23,10 @@ import Control.DeepSeq
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.List
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory
import System.Environment
import System.FilePath
import System.IO
import System.Process
@@ -38,7 +34,6 @@ import System.Process
import qualified Control.Exception as EX
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
@@ -68,7 +63,7 @@ readCreateProcessWithExitCodeBS cp input = do
std_out = CreatePipe,
std_err = CreatePipe
}
withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
withCreateProcess_ "readCreateProcessWithExitCode" cp_opts $
\mb_inh mb_outh mb_errh ph ->
case (mb_inh, mb_outh, mb_errh) of
(Just inh, Just outh, Just errh) -> do
@@ -135,14 +130,12 @@ withForkWait async' body = do
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
=> FilePath -- ^ command as filename, e.g. 'ls'
executeOut :: FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess
-> IO CapturedProcess
executeOut path args chdir = do
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
(exit, out, err) <- readCreateProcessWithExitCodeBS (proc path args){ cwd = chdir } ""
pure $ CapturedProcess exit out err
@@ -157,16 +150,15 @@ execLogged exe args chdir lfile env = do
AppState { dirs = Dirs {..} } <- ask
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args)
{ cwd = chdir
, env = env
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
})
fmap (toProcessError exe args)
$ liftIO
$ withCreateProcess cp
$ withCreateProcess
(proc exe args){ cwd = chdir
, env = env
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
$ \_ mout merr ph ->
case (mout, merr) of
(Just cStdout, Just cStderr) -> do
@@ -192,15 +184,15 @@ execLogged exe args chdir lfile env = do
-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
=> FilePath -- ^ thing to execute
exec :: FilePath -- ^ thing to execute
-> [FilePath] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
-> IO (Either ProcessError ())
exec exe args chdir env = do
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
exit_code <- withCreateProcess
(proc exe args) { cwd = chdir, env = env } $ \_ _ _ p ->
waitForProcess p
pure $ toProcessError exe args exit_code
@@ -208,40 +200,3 @@ chmod_755 :: MonadIO m => FilePath -> m ()
chmod_755 fp =
let perm = setOwnerWritable True emptyPermissions
in liftIO $ setPermissions fp perm
createProcessWithMingwPath :: MonadIO m
=> CreateProcess
-> m CreateProcess
createProcessWithMingwPath cp = do
msys2Dir <- liftIO ghcupMsys2Dir
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
let mingWPaths = [msys2Dir </> "usr" </> "bin"
,msys2Dir </> "mingw64" </> "bin"]
paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
envWithNewPath = Map.insert "Path" newPath envWithoutPath
liftIO $ setEnv "Path" newPath
pure $ cp { env = Just $ Map.toList envWithNewPath }
ghcupMsys2Dir :: IO FilePath
ghcupMsys2Dir =
lookupEnv "GHCUP_MSYS2" >>= \case
Just fp -> pure fp
Nothing -> do
baseDir <- liftIO ghcupBaseDir
pure (baseDir </> "msys64")
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
b <- pathIsLink fp
if b
then do
tfp <- getLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(takeDirectory fp </> tfp)
else pure False

View File

@@ -14,11 +14,13 @@ Here we define our main logger.
-}
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils.File
import GHCup.Utils.String.QQ
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import Prelude hiding ( appendFile )
import System.Console.Pretty
@@ -66,8 +68,9 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr
initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
initGHCupFileLogging logsDir = do
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m FilePath
initGHCupFileLogging = do
AppState {dirs = Dirs {..}} <- ask
let logfile = logsDir </> "ghcup.log"
liftIO $ do
createDirectoryIfMissing True logsDir
@@ -77,7 +80,7 @@ initGHCupFileLogging logsDir = do
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . removeFile . (logsDir </>)
writeFile logfile ""
pure logfile

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -26,8 +25,6 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub )
import Data.Foldable
import Data.String
import Data.Text ( Text )
import Data.Versions
@@ -35,15 +32,6 @@ import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.IO.Unsafe
import System.Directory
import System.FilePath
#if defined(IS_WINDOWS)
import Control.Retry
import GHC.IO.Exception
#endif
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
@@ -288,139 +276,3 @@ escapeVerRex = B.pack . go . B.unpack . verToBS
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
| otherwise = x : go xs
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirectoryIfMissing True
$ p
where
isSymlinkDir e = do
ft <- pathIsSymbolicLink p
case ft of
True -> do
rp <- canonicalizePath p
rft <- doesDirectoryExist rp
case rft of
True -> pure ()
_ -> throwIO e
_ -> throwIO e
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
dest = targetDir </> srcFile
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
files' <- recurseDirectories (dirs' ++ dirs)
return (files ++ files')
where
collect files dirs' [] = return (reverse files
,reverse dirs')
collect files dirs' (entry:entries) | ignore entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist (topdir </> dirEntry)
if isDirectory
then collect files (dirEntry:dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
rmPath :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmPath fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
]
(\_ -> liftIO $ removePathForcibly fp)
#else
liftIO $ removeDirectoryRecursive fp
#endif
-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
rmFile :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmFile fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeFile fp)
#else
liftIO $ removeFile fp
#endif
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | Strip @\\r@ and @\\n@ from 'ByteString's
stripNewline :: String -> String
stripNewline s
| null s = []
| head s `elem` "\n\r" = stripNewline (tail s)
| otherwise = head s : stripNewline (tail s)
isNewLine :: Word8 -> Bool
isNewLine w
| w == _lf = True
| w == _cr = True
| otherwise = False

View File

@@ -25,7 +25,7 @@ import qualified Data.Text as T
-- | This reflects the API version of the YAML.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.5.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.4.yaml|]
-- | The current ghcup version.
ghcUpVer :: PVP

View File

@@ -37,7 +37,6 @@ extra-deps:
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- zip-1.7.1@sha256:0ce03d0fbffba47c1ab6fbb9166f8ba5373d828d78587df21b7e9d7bb150f929,3918
flags:
http-io-streams:

View File

@@ -171,10 +171,6 @@ instance Arbitrary Tool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GlobalTool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink

View File

@@ -20,7 +20,7 @@
</a>
<p id="pitch">
<em>ghcup</em> is the main installer for<br/>
<em>ghcup</em> is an installer for<br/>
the general purpose language <a href="https://www.haskell.org/">Haskell</a>
</p>
@@ -49,11 +49,11 @@
<p>
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
<p>If you're a Windows Subsystem 2 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
</p>
<p class="other-help">WSL1 does not work with ghcup, follow <a href="https://docs.microsoft.com/en-us/windows/wsl/install-win10">the instructions here</a> to upgrade to WSL2 if needed.</br>You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
<div id="platform-instructions-win64" class="instructions" style="display: none;">
@@ -61,10 +61,10 @@
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
<p>If you're a Windows Subsystem 2 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">WSL1 does not work with ghcup, follow <a href="https://docs.microsoft.com/en-us/windows/wsl/install-win10">the instructions here</a> to upgrade to WSL2 if needed.</br>You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
<div id="platform-instructions-unknown" class="instructions" style="display: none;">
@@ -86,7 +86,7 @@
<!-- duplicate the default cross-platform instructions -->
<div>
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem 2 for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
</div>
@@ -104,7 +104,7 @@
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS (on Intel), FreeBSD or Windows Subsystem 2 for Linux, run the following
<p>To install Haskell, if you are running Linux, macOS (on Intel), FreeBSD or Windows Subsystem for Linux, run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p>For macOS on Apple Silicon, run this instead:</p>
@@ -124,7 +124,7 @@
</div>
<p>
Need help? Ask on <a href="https://kiwiirc.com/nextclient/irc.libera.chat/#haskell-ghcup">#haskell-ghcup</a>, <a href="https://kiwiirc.com/nextclient/irc.libera.chat/#haskell">#haskell</a> or <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">report a bug</a>.
Need help? <a href="http://webchat.freenode.net/?randomnick=1&channels=%23haskell&uio=d4">Ask on #haskell</a> or <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">report a bug</a>.
</p>
<p id="about">
@@ -145,13 +145,13 @@
<noscript>
<p id="pitch">
<em>ghcup</em> is the main installer for<br/>
<em>ghcup</em> is an installer for<br/>
the general purpose language <a href="https://www.haskell.org/">Haskell</a>
</p>
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS (on Intel), FreeBSD or Windows Subsystem for Linux 2, run the following
<p>To install Haskell, if you are running Linux, macOS (on Intel), FreeBSD or Windows Subsystem for Linux, run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre>
<p>For macOS on Apple Silicon, run this instead:</p>
@@ -171,7 +171,7 @@
</div>
<p>
Need help? Ask on <a href="https://kiwiirc.com/nextclient/irc.libera.chat/#haskell-ghcup">#haskell-ghcup</a>, <a href="https://kiwiirc.com/nextclient/irc.libera.chat/#haskell">#haskell</a> or <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">report a bug</a>.
Need help? <a href="http://webchat.freenode.net/?randomnick=1&amp;channels=%23haskell&amp;uio=d4">Ask on #haskell</a>.
</p>
<p id="about">