Merge branch 'issue-180'
This commit is contained in:
commit
5217aa0a1d
GPG Key ID:
3786C5262ECB4A3F
@ -21,6 +21,7 @@ variables:
|
||||
OS: "LINUX"
|
||||
ARCH: "64"
|
||||
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
|
||||
CROSS: ""
|
||||
|
||||
.alpine:64bit:
|
||||
image: "alpine:3.12"
|
||||
@ -268,6 +269,24 @@ test:linux:latest:
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
test:linux:cross-armv7:
|
||||
stage: test
|
||||
extends:
|
||||
- .test_ghcup_version
|
||||
- .debian
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
GHC_TARGET_VERSION: "8.10.5"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: "arm-linux-gnueabihf"
|
||||
needs: []
|
||||
when: manual
|
||||
before_script:
|
||||
- ./.gitlab/before_script/linux/install_deps.sh
|
||||
script:
|
||||
- ./.gitlab/script/ghcup_cross.sh
|
||||
|
||||
|
||||
######## linux 32bit test ########
|
||||
|
||||
test:linux:recommended:32bit:
|
||||
@ -286,6 +305,7 @@ test:linux:recommended:armv7:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
@ -295,6 +315,7 @@ test:linux:recommended:aarch64:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
@ -394,6 +415,7 @@ release:linux:armv7:
|
||||
ARTIFACT: "armv7-linux-ghcup"
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
|
||||
release:linux:aarch64:
|
||||
stage: release
|
||||
@ -407,6 +429,7 @@ release:linux:aarch64:
|
||||
ARTIFACT: "aarch64-linux-ghcup"
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
|
||||
######## darwin release ########
|
||||
|
||||
|
||||
@ -9,6 +9,13 @@ mkdir -p "${TMPDIR}"
|
||||
sudo apt-get update -y
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https
|
||||
|
||||
if [ "${CROSS}" = "arm-linux-gnueabihf" ] ; then
|
||||
sudo apt-get install -y autoconf build-essential gcc-arm-linux-gnueabihf
|
||||
sudo dpkg --add-architecture armhf
|
||||
sudo apt-get update -y
|
||||
sudo apt-get install -y libncurses-dev:armhf
|
||||
fi
|
||||
|
||||
case "${ARCH}" in
|
||||
ARM*)
|
||||
case "${ARCH}" in
|
||||
@ -57,9 +64,9 @@ case "${ARCH}" in
|
||||
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}
|
||||
./ghcup-bin install ghc ${GHC_VERSION}
|
||||
./ghcup-bin set ghc ${GHC_VERSION}
|
||||
./ghcup-bin install cabal ${CABAL_VERSION}
|
||||
|
||||
;;
|
||||
esac
|
||||
|
||||
52
.gitlab/script/ghcup_cross.sh
Executable file
52
.gitlab/script/ghcup_cross.sh
Executable file
@ -0,0 +1,52 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -eux
|
||||
|
||||
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
|
||||
|
||||
mkdir -p "$CI_PROJECT_DIR"/.local/bin
|
||||
|
||||
CI_PROJECT_DIR=$(pwd)
|
||||
|
||||
ecabal() {
|
||||
cabal "$@"
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
}
|
||||
|
||||
git describe --always
|
||||
|
||||
### build
|
||||
|
||||
ecabal update
|
||||
|
||||
ecabal build -w ghc-${GHC_VERSION}
|
||||
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
|
||||
|
||||
### cleanup
|
||||
|
||||
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
|
||||
|
||||
### manual cli based testing
|
||||
|
||||
eghcup --numeric-version
|
||||
|
||||
eghcup install ghc ${GHC_VERSION}
|
||||
eghcup set ghc ${GHC_VERSION}
|
||||
eghcup install cabal ${CABAL_VERSION}
|
||||
|
||||
cabal --version
|
||||
|
||||
eghcup debug-info
|
||||
|
||||
eghcup compile ghc -j $(nproc) -v ${GHC_TARGET_VERSION} -b ${GHC_VERSION} -x ${CROSS} -- --enable-unregisterised
|
||||
eghcup set ghc ${CROSS}-${GHC_TARGET_VERSION}
|
||||
|
||||
[ `$(eghcup whereis ghc ${CROSS}-${GHC_TARGET_VERSION}) --numeric-version` = "${GHC_TARGET_VERSION}" ]
|
||||
|
||||
# nuke
|
||||
eghcup nuke
|
||||
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
|
||||
|
||||
@ -15,10 +15,6 @@ git describe
|
||||
# build
|
||||
ecabal update
|
||||
|
||||
(
|
||||
cd /tmp
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
|
||||
)
|
||||
|
||||
if [ "${OS}" = "LINUX" ] ; then
|
||||
if [ "${ARCH}" = "32" ] ; then
|
||||
|
||||
@ -26,11 +26,6 @@ git describe --always
|
||||
|
||||
ecabal update
|
||||
|
||||
(
|
||||
cd /tmp
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
|
||||
)
|
||||
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} -ftui
|
||||
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
|
||||
@ -83,10 +78,10 @@ ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
|
||||
|
||||
eghcup --numeric-version
|
||||
|
||||
eghcup install ${GHC_VERSION}
|
||||
eghcup install ghc ${GHC_VERSION}
|
||||
[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
|
||||
eghcup set ${GHC_VERSION}
|
||||
eghcup install-cabal ${CABAL_VERSION}
|
||||
eghcup set ghc ${GHC_VERSION}
|
||||
eghcup install cabal ${CABAL_VERSION}
|
||||
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
|
||||
|
||||
cabal --version
|
||||
@ -112,17 +107,19 @@ else
|
||||
# test installing new ghc doesn't mess with currently set GHC
|
||||
# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
|
||||
if [ "${OS}" = "LINUX" ] ; then
|
||||
eghcup --downloader=wget install 8.10.3
|
||||
eghcup --downloader=wget prefetch ghc 8.10.3
|
||||
eghcup --offline install ghc 8.10.3
|
||||
else # test wget a bit
|
||||
eghcup install 8.10.3
|
||||
eghcup prefetch ghc 8.10.3
|
||||
eghcup --offline install ghc 8.10.3
|
||||
fi
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
eghcup set 8.10.3
|
||||
eghcup --offline set 8.10.3
|
||||
eghcup set 8.10.3
|
||||
[ "$(ghc --numeric-version)" = "8.10.3" ]
|
||||
eghcup set ${GHC_VERSION}
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
eghcup rm 8.10.3
|
||||
eghcup --offline rm 8.10.3
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
|
||||
@ -12,7 +12,7 @@ import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types hiding ( LeanAppState (..) )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
, rawOutter = \_ -> pure ()
|
||||
}
|
||||
downloadAll dli = do
|
||||
dirs <- liftIO getDirs
|
||||
dirs <- liftIO getAllDirs
|
||||
|
||||
pfreq <- (
|
||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
||||
@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
($(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 appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
|
||||
|
||||
r <-
|
||||
runLogger
|
||||
@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
case etool of
|
||||
Right (Just GHCup) -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
|
||||
_ <- liftE $ download dli tmpUnpack Nothing
|
||||
pure Nothing
|
||||
Right _ -> do
|
||||
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing
|
||||
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
|
||||
_ <- liftE $ download dli tmpUnpack Nothing
|
||||
pure Nothing
|
||||
case r of
|
||||
VRight (Just basePath) -> do
|
||||
|
||||
@ -13,7 +13,7 @@ module BrickMain where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types hiding ( LeanAppState(..) )
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Prelude ( decUTF8Safe )
|
||||
import GHCup.Utils.File
|
||||
@ -53,8 +53,6 @@ import System.IO.Unsafe
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified GHCup.Types as GT
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Data.Vector as V
|
||||
@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do
|
||||
settings' :: IORef AppState
|
||||
{-# NOINLINE settings' #-}
|
||||
settings' = unsafePerformIO $ do
|
||||
dirs <- getDirs
|
||||
dirs <- getAllDirs
|
||||
newIORef $ AppState (Settings { cache = True
|
||||
, noVerify = False
|
||||
, keepDirs = Never
|
||||
, downloader = Curl
|
||||
, verbose = False
|
||||
, urlSource = GHCupURL
|
||||
, noNetwork = False
|
||||
, ..
|
||||
})
|
||||
dirs
|
||||
@ -578,9 +577,8 @@ logger' = unsafePerformIO
|
||||
|
||||
brickMain :: AppState
|
||||
-> LoggerConfig
|
||||
-> GHCupInfo
|
||||
-> IO ()
|
||||
brickMain s l gi = do
|
||||
brickMain s l = do
|
||||
writeIORef settings' s
|
||||
-- logger interpreter
|
||||
writeIORef logger' l
|
||||
@ -588,7 +586,7 @@ brickMain s l gi = do
|
||||
|
||||
no_color <- isJust <$> lookupEnv "NO_COLOR"
|
||||
|
||||
eAppData <- getAppData (Just gi)
|
||||
eAppData <- getAppData (Just $ ghcupInfo s)
|
||||
case eAppData of
|
||||
Right ad ->
|
||||
defaultMain
|
||||
@ -596,7 +594,7 @@ brickMain s l gi = do
|
||||
(BrickState ad
|
||||
defaultAppSettings
|
||||
(constructList ad defaultAppSettings Nothing)
|
||||
(keyBindings s)
|
||||
(keyBindings (s :: AppState))
|
||||
|
||||
)
|
||||
$> ()
|
||||
@ -620,7 +618,7 @@ getGHCupInfo = do
|
||||
. flip runReaderT settings
|
||||
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
$ liftE
|
||||
$ getDownloadsF (GT.settings settings) (GT.dirs settings)
|
||||
$ getDownloadsF
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
|
||||
@ -21,6 +21,7 @@ import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Requirements
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
@ -66,7 +67,6 @@ import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.IO hiding ( appendFile )
|
||||
import System.IO.Unsafe ( unsafeInterleaveIO )
|
||||
import Text.Read hiding ( lift )
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
@ -91,6 +91,7 @@ data Options = Options
|
||||
, optNoVerify :: Maybe Bool
|
||||
, optKeepDirs :: Maybe KeepDirs
|
||||
, optsDownloader :: Maybe Downloader
|
||||
, optNoNetwork :: Maybe Bool
|
||||
-- commands
|
||||
, optCommand :: Command
|
||||
}
|
||||
@ -111,6 +112,7 @@ data Command
|
||||
#if defined(BRICK)
|
||||
| Interactive
|
||||
#endif
|
||||
| Prefetch PrefetchCommand
|
||||
|
||||
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
|
||||
| ToolTag Tag
|
||||
@ -200,6 +202,21 @@ data WhereisOptions = WhereisOptions {
|
||||
directory :: Bool
|
||||
}
|
||||
|
||||
data PrefetchOptions = PrefetchOptions {
|
||||
pfCacheDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
|
||||
| PrefetchCabal PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchHLS PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchStack PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchMetadata
|
||||
|
||||
data PrefetchGHCOptions = PrefetchGHCOptions {
|
||||
pfGHCSrc :: Bool
|
||||
, pfGHCCacheDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
|
||||
-- https://github.com/pcapriotti/optparse-applicative/issues/148
|
||||
|
||||
@ -277,6 +294,7 @@ opts =
|
||||
#endif
|
||||
<> hidden
|
||||
))
|
||||
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
|
||||
<*> com
|
||||
where
|
||||
parseUri s' =
|
||||
@ -357,6 +375,16 @@ com =
|
||||
(progDesc "Find a tools location"
|
||||
<> footerDoc ( Just $ text whereisFooter ))
|
||||
)
|
||||
<> command
|
||||
"prefetch"
|
||||
(info
|
||||
( (Prefetch
|
||||
<$> prefetchP
|
||||
) <**> helper
|
||||
)
|
||||
(progDesc "Prefetch assets"
|
||||
<> footerDoc ( Just $ text prefetchFooter ))
|
||||
)
|
||||
<> commandGroup "Main commands:"
|
||||
)
|
||||
<|> subparser
|
||||
@ -440,6 +468,17 @@ Examples:
|
||||
# outputs ~/.ghcup/bin/
|
||||
ghcup whereis --directory cabal 3.4.0.0|]
|
||||
|
||||
prefetchFooter :: String
|
||||
prefetchFooter = [s|Discussion:
|
||||
Prefetches tools or assets into "~/.ghcup/cache" directory. This can
|
||||
be then combined later with '--offline' flag, ensuring all assets that
|
||||
are required for offline use have been prefetched.
|
||||
|
||||
Examples:
|
||||
ghcup prefetch metadata
|
||||
ghcup prefetch ghc 8.10.5
|
||||
ghcup --offline install ghc 8.10.5|]
|
||||
|
||||
|
||||
installCabalFooter :: String
|
||||
installCabalFooter = [s|Discussion:
|
||||
@ -825,6 +864,55 @@ Examples:
|
||||
ghcup whereis --directory stack 2.7.1|]
|
||||
|
||||
|
||||
prefetchP :: Parser PrefetchCommand
|
||||
prefetchP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
(info
|
||||
(PrefetchGHC
|
||||
<$> (PrefetchGHCOptions
|
||||
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
|
||||
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just GHC)) ))
|
||||
( progDesc "Download GHC assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"cabal"
|
||||
(info
|
||||
(PrefetchCabal
|
||||
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
|
||||
( progDesc "Download cabal assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"hls"
|
||||
(info
|
||||
(PrefetchHLS
|
||||
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
|
||||
( progDesc "Download HLS assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"stack"
|
||||
(info
|
||||
(PrefetchStack
|
||||
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
|
||||
( progDesc "Download stack assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"metadata"
|
||||
(const PrefetchMetadata <$> info
|
||||
helper
|
||||
( progDesc "Download ghcup's metadata, needed for various operations")
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
ghcCompileOpts :: Parser GHCCompileOptions
|
||||
ghcCompileOpts =
|
||||
GHCCompileOptions
|
||||
@ -942,14 +1030,20 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
|
||||
|
||||
tagCompleter :: Tool -> [String] -> Completer
|
||||
tagCompleter tool add = listIOCompleter $ do
|
||||
dirs' <- liftIO getDirs
|
||||
dirs' <- liftIO getAllDirs
|
||||
let appState = LeanAppState
|
||||
(Settings True False Never Curl False GHCupURL True)
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = False
|
||||
, colorOutter = mempty
|
||||
, rawOutter = mempty
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
|
||||
|
||||
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
|
||||
case mGhcUpInfo of
|
||||
VRight ghcupInfo -> do
|
||||
let allTags = filter (\t -> t /= Old)
|
||||
@ -962,19 +1056,24 @@ tagCompleter tool add = listIOCompleter $ do
|
||||
|
||||
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
|
||||
versionCompleter criteria tool = listIOCompleter $ do
|
||||
dirs' <- liftIO getDirs
|
||||
dirs' <- liftIO getAllDirs
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = False
|
||||
, colorOutter = mempty
|
||||
, rawOutter = mempty
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
|
||||
mpFreq <- runLogger . runE $ platformRequest
|
||||
forFold mpFreq $ \pfreq ->
|
||||
settings = Settings True False Never Curl False GHCupURL True
|
||||
let leanAppState = LeanAppState
|
||||
settings
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
|
||||
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
|
||||
forFold mpFreq $ \pfreq -> do
|
||||
forFold mGhcUpInfo $ \ghcupInfo -> do
|
||||
let appState = AppState
|
||||
(Settings True False Never Curl False GHCupURL)
|
||||
settings
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
ghcupInfo
|
||||
@ -1123,6 +1222,7 @@ toSettings options = do
|
||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
||||
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
|
||||
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
|
||||
in (Settings {..}, keyBindings)
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
defaultDownloader = Internal
|
||||
@ -1167,8 +1267,10 @@ 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
|
||||
dirs <- liftIO getAllDirs
|
||||
let settings = AppState (Settings True False Never Curl False GHCupURL False)
|
||||
dirs
|
||||
defaultKeyBindings
|
||||
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
|
||||
@ -1220,7 +1322,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(footerDoc (Just $ text main_footer))
|
||||
)
|
||||
>>= \opt@Options {..} -> do
|
||||
dirs <- getDirs
|
||||
dirs@Dirs{..} <- getAllDirs
|
||||
|
||||
-- create ~/.ghcup dir
|
||||
ensureDirectories dirs
|
||||
@ -1228,7 +1330,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(settings, keybindings) <- toSettings opt
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- initGHCupFileLogging (logsDir dirs)
|
||||
logfile <- initGHCupFileLogging logsDir
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = verbose settings
|
||||
, colorOutter = B.hPut stderr
|
||||
@ -1240,68 +1342,64 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
|
||||
|
||||
----------------------------------------
|
||||
-- Getting download and platform info --
|
||||
----------------------------------------
|
||||
|
||||
|
||||
pfreq <- unsafeInterleaveIO $ (
|
||||
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 <- unsafeInterleaveIO $
|
||||
( 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)
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
-- Setting up appstate --
|
||||
-------------------------
|
||||
|
||||
|
||||
let appstate@AppState{dirs = Dirs{..}
|
||||
, ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. }
|
||||
} = AppState settings dirs keybindings ghcupInfo pfreq
|
||||
let leanAppstate = LeanAppState settings dirs keybindings
|
||||
appState = do
|
||||
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 <-
|
||||
( runLogger
|
||||
. flip runReaderT leanAppstate
|
||||
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE
|
||||
$ getDownloadsF
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
let s' = AppState settings dirs keybindings ghcupInfo pfreq
|
||||
|
||||
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
|
||||
Just _ -> pure ()
|
||||
|
||||
-- TODO: always run for windows
|
||||
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 30)
|
||||
pure s'
|
||||
|
||||
|
||||
---------------------------
|
||||
-- Running startup tasks --
|
||||
---------------------------
|
||||
#if defined(IS_WINDOWS)
|
||||
-- FIXME: windows needs 'ensureGlobalTools', which requires
|
||||
-- full appstate
|
||||
runLeanAppState = runAppState
|
||||
#else
|
||||
runLeanAppState = flip runReaderT leanAppstate
|
||||
#endif
|
||||
runAppState action' = do
|
||||
s' <- liftIO appState
|
||||
flip runReaderT s' action'
|
||||
|
||||
|
||||
case optCommand of
|
||||
Upgrade _ _ -> pure ()
|
||||
Whereis _ _ -> pure ()
|
||||
_ -> do
|
||||
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates
|
||||
Just _ -> pure ()
|
||||
|
||||
|
||||
-- ensure global tools
|
||||
case optCommand of
|
||||
Whereis _ _ -> pure ()
|
||||
_ -> do
|
||||
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 30)
|
||||
|
||||
|
||||
-------------------------
|
||||
@ -1310,7 +1408,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
let runInstTool' appstate' mInstPlatform =
|
||||
runLogger
|
||||
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform)
|
||||
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
@ -1331,12 +1429,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
let runInstTool = runInstTool' appstate
|
||||
let runInstTool mInstPlatform action' = do
|
||||
s' <- liftIO appState
|
||||
runInstTool' s' mInstPlatform action'
|
||||
|
||||
let
|
||||
runLeanSetGHC =
|
||||
runLogger
|
||||
. runLeanAppState
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
@ -1346,9 +1457,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
]
|
||||
|
||||
let
|
||||
runLeanSetCabal =
|
||||
runLogger
|
||||
. runLeanAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
runSetCabal =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
@ -1359,7 +1480,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let
|
||||
runSetHLS =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
@ -1367,20 +1488,30 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
let runListGHC = runLogger . flip runReaderT appstate
|
||||
runLeanSetHLS =
|
||||
runLogger
|
||||
. runLeanAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
let runListGHC = runLogger . runAppState
|
||||
|
||||
let runRm =
|
||||
runLogger . flip runReaderT appstate . runE @'[NotInstalled]
|
||||
runLogger . runAppState . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
|
||||
let runCompileGHC =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
@ -1400,9 +1531,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
]
|
||||
|
||||
let
|
||||
runLeanWhereIs =
|
||||
runLogger
|
||||
-- Don't use runLeanAppState here, which is disabled on windows.
|
||||
-- This is the only command on all platforms that doesn't need full appstate.
|
||||
. flip runReaderT leanAppstate
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, NoToolVersionSet
|
||||
, NextVerNotFound
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
runWhereIs =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, NoToolVersionSet
|
||||
@ -1412,7 +1555,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
let runUpgrade =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ DigestError
|
||||
@ -1423,6 +1566,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runPrefetch =
|
||||
runLogger
|
||||
. runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, NoDownload
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, JSONError
|
||||
, FileDoesNotExistError
|
||||
]
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Command functions --
|
||||
@ -1435,13 +1593,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
liftE $ installGHCBin (_tvVersion v)
|
||||
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
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- liftIO appState
|
||||
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@ -1473,12 +1633,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@ -1502,12 +1664,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@ -1531,12 +1695,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@ -1555,11 +1721,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
|
||||
let setGHC' SetOptions{..} =
|
||||
runSetGHC (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
let setGHC' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
|
||||
_ -> runSetGHC (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@ -1570,12 +1738,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 5
|
||||
|
||||
let setCabal' SetOptions{..} =
|
||||
runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
|
||||
liftE $ setCabal (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
let setCabal' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
|
||||
_ -> runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
|
||||
liftE $ setCabal (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@ -1586,12 +1756,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setHLS' SetOptions{..} =
|
||||
runSetHLS (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
let setHLS' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
|
||||
_ -> runSetHLS (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@ -1602,12 +1774,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setStack' SetOptions{..} =
|
||||
runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Stack
|
||||
liftE $ setStack (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
let setStack' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
|
||||
_ -> runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Stack
|
||||
liftE $ setStack (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@ -1622,6 +1796,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmGHCVer ghcVer
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
|
||||
)
|
||||
>>= \case
|
||||
@ -1637,6 +1812,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmCabalVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo tv Cabal dls)
|
||||
)
|
||||
>>= \case
|
||||
@ -1652,6 +1828,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmHLSVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo tv HLS dls)
|
||||
)
|
||||
>>= \case
|
||||
@ -1667,6 +1844,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmStackVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo tv Stack dls)
|
||||
)
|
||||
>>= \case
|
||||
@ -1681,7 +1859,8 @@ 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
|
||||
s' <- appState
|
||||
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
|
||||
#endif
|
||||
Install (Right iopts) -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
||||
@ -1731,6 +1910,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runCompileGHC (do
|
||||
case targetGhc of
|
||||
Left targetVer -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo targetVer GHC dls
|
||||
forM_ (_viPreCompile =<< vi) $ \msg -> do
|
||||
lift $ $(logInfo) msg
|
||||
@ -1746,6 +1926,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
buildConfig
|
||||
patchDir
|
||||
addConfArgs
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
|
||||
when setCompile $ void $ liftE $
|
||||
setGHC targetVer SetGHCOnly
|
||||
@ -1773,6 +1954,21 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 9
|
||||
|
||||
Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
|
||||
runLeanWhereIs (do
|
||||
loc <- liftE $ whereIsTool tool v
|
||||
if directory
|
||||
then pure $ takeDirectory loc
|
||||
else pure loc
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> do
|
||||
putStr r
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
|
||||
runWhereIs (do
|
||||
(v, _) <- liftE $ fromVersion whereVer tool
|
||||
@ -1797,6 +1993,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
runUpgrade (liftE $ upgradeGHCup target force') >>= \case
|
||||
VRight v' -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
|
||||
let pretty_v = prettyVer v'
|
||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||
runLogger $ $(logInfo)
|
||||
@ -1811,23 +2008,26 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 11
|
||||
|
||||
ToolRequirements ->
|
||||
flip runReaderT appstate
|
||||
$ runLogger
|
||||
(runE
|
||||
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
|
||||
$ do
|
||||
platform <- liftE getPlatform
|
||||
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements
|
||||
liftIO $ T.hPutStr stdout (prettyRequirements req)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 12
|
||||
ToolRequirements -> do
|
||||
s' <- appState
|
||||
flip runReaderT s'
|
||||
$ runLogger
|
||||
(runE
|
||||
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
|
||||
$ do
|
||||
GHCupInfo { .. } <- lift getGHCupInfo
|
||||
platform' <- liftE getPlatform
|
||||
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
|
||||
liftIO $ T.hPutStr stdout (prettyRequirements req)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 12
|
||||
|
||||
ChangeLog ChangeLogOptions{..} -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
|
||||
let tool = fromMaybe GHC clTool
|
||||
ver' = maybe
|
||||
(Right Latest)
|
||||
@ -1845,6 +2045,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
)
|
||||
pure ExitSuccess
|
||||
Just uri -> do
|
||||
pfreq <- runAppState getPlatformReq
|
||||
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
||||
cmd = case _rPlatform pfreq of
|
||||
Darwin -> "open"
|
||||
@ -1853,21 +2054,23 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
Windows -> "start"
|
||||
|
||||
if clOpen
|
||||
then
|
||||
flip runReaderT appstate $
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
Right _ -> pure ExitSuccess
|
||||
Left e -> runLogger ($(logError) [i|#{e}|])
|
||||
>> pure (ExitFailure 13)
|
||||
then do
|
||||
s' <- appState
|
||||
flip runReaderT s' $
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
Right _ -> pure ExitSuccess
|
||||
Left e -> runLogger ($(logError) [i|#{e}|])
|
||||
>> pure (ExitFailure 13)
|
||||
else putStrLn uri' >> pure ExitSuccess
|
||||
|
||||
Nuke ->
|
||||
runRm (do
|
||||
void $ liftIO $ evaluate $ force appstate
|
||||
s' <- liftIO appState
|
||||
void $ liftIO $ evaluate $ force s'
|
||||
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
|
||||
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
|
||||
liftIO $ threadDelay 10000000 -- wait 10s
|
||||
@ -1894,6 +2097,37 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
Prefetch pfCom ->
|
||||
runPrefetch (do
|
||||
case pfCom of
|
||||
PrefetchGHC
|
||||
(PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt GHC
|
||||
if pfGHCSrc
|
||||
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
|
||||
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
|
||||
PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Cabal
|
||||
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
|
||||
PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt HLS
|
||||
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
|
||||
PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Stack
|
||||
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
|
||||
PrefetchMetadata -> do
|
||||
_ <- liftE $ getDownloadsF
|
||||
pure ""
|
||||
) >>= \case
|
||||
VRight _ -> do
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
|
||||
case res of
|
||||
@ -1903,22 +2137,46 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
pure ()
|
||||
|
||||
fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
|
||||
fromVersion :: ( MonadLogger m
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion tv = fromVersion' (toSetToolVer tv)
|
||||
|
||||
fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
|
||||
fromVersion' :: ( MonadLogger m
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> SetToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion' SetRecommended tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
|
||||
?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolVersion v) tool = do
|
||||
~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (_tvVersion v) tool dls
|
||||
case pvp $ prettyVer (_tvVersion v) of
|
||||
Left _ -> pure (v, vi)
|
||||
@ -1928,16 +2186,16 @@ fromVersion' (SetToolVersion v) tool = do
|
||||
Nothing -> pure (v, vi)
|
||||
Right _ -> pure (v, vi)
|
||||
fromVersion' (SetToolTag Latest) tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
|
||||
fromVersion' (SetToolTag Recommended) tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(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
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
|
||||
fromVersion' SetNext tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
next <- case tool of
|
||||
GHC -> do
|
||||
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
|
||||
@ -2138,7 +2396,10 @@ printListResult raw lr = do
|
||||
| otherwise -> 1
|
||||
|
||||
|
||||
checkForUpdates :: ( MonadReader AppState m
|
||||
checkForUpdates :: ( MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
@ -2148,7 +2409,7 @@ checkForUpdates :: ( MonadReader AppState m
|
||||
)
|
||||
=> m ()
|
||||
checkForUpdates = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
||||
lInstalled <- listVersions Nothing (Just ListInstalled)
|
||||
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
|
||||
|
||||
|
||||
@ -116,7 +116,7 @@ library
|
||||
, megaparsec >=8.0.0 && <9.1
|
||||
, monad-logger ^>=0.3.31
|
||||
, mtl ^>=2.2
|
||||
, optics >=0.2 && <0.5
|
||||
, optics ^>=0.4
|
||||
, optics-vl ^>=0.2
|
||||
, os-release ^>=1.0.0
|
||||
, parsec ^>=3.1
|
||||
@ -279,7 +279,7 @@ executable ghcup-gen
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
, monad-logger ^>=0.3.31
|
||||
, mtl ^>=2.2
|
||||
, optics >=0.2 && <0.5
|
||||
, optics ^>=0.4
|
||||
, optparse-applicative >=0.15.1.0 && <0.17
|
||||
, pretty ^>=1.1.3.1
|
||||
, pretty-terminal ^>=0.1.0.0
|
||||
|
||||
445
lib/GHCup.hs
445
lib/GHCup.hs
@ -95,6 +95,69 @@ import GHCup.Utils.MegaParsec
|
||||
import Control.Concurrent (threadDelay)
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Tool fetching ]--
|
||||
---------------------
|
||||
|
||||
|
||||
fetchToolBindist :: ( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> Tool
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
'[ DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
FilePath
|
||||
fetchToolBindist v t mfp = do
|
||||
dlinfo <- liftE $ getDownloadInfo t v
|
||||
liftE $ downloadCached' dlinfo Nothing mfp
|
||||
|
||||
|
||||
fetchGHCSrc :: ( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
'[ DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
FilePath
|
||||
fetchGHCSrc v mfp = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
dlInfo <-
|
||||
preview (ix GHC % ix v % viSourceDL % _Just) dls
|
||||
?? NoDownload
|
||||
liftE $ downloadCached' dlInfo Nothing mfp
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Tool installation ]--
|
||||
@ -106,7 +169,10 @@ import Control.Concurrent (threadDelay)
|
||||
installGHCBindist :: ( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -130,14 +196,12 @@ installGHCBindist :: ( MonadFail m
|
||||
m
|
||||
()
|
||||
installGHCBindist dlinfo ver = do
|
||||
AppState { dirs , settings } <- lift ask
|
||||
|
||||
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
|
||||
@ -163,7 +227,10 @@ installGHCBindist dlinfo ver = do
|
||||
-- build system and nothing else.
|
||||
installPackedGHC :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, HasSettings env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
@ -182,7 +249,7 @@ installPackedGHC :: ( MonadMask m
|
||||
#endif
|
||||
] m ()
|
||||
installPackedGHC dl msubdir inst ver = do
|
||||
AppState { pfreq = PlatformRequest {..} } <- lift ask
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
@ -201,7 +268,10 @@ installPackedGHC dl msubdir inst ver = do
|
||||
|
||||
-- | Install an unpacked GHC distribution. This only deals with the GHC
|
||||
-- build system and nothing else.
|
||||
installUnpackedGHC :: ( MonadReader AppState m
|
||||
installUnpackedGHC :: ( MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
@ -218,7 +288,7 @@ installUnpackedGHC path inst _ = do
|
||||
liftIO $ copyDirectoryRecursive path inst
|
||||
#else
|
||||
installUnpackedGHC path inst ver = do
|
||||
AppState { pfreq = PlatformRequest {..} } <- lift ask
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
|
||||
let alpineArgs
|
||||
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
|
||||
@ -250,7 +320,11 @@ installUnpackedGHC path inst ver = do
|
||||
installGHCBin :: ( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -273,9 +347,7 @@ installGHCBin :: ( MonadFail m
|
||||
m
|
||||
()
|
||||
installGHCBin ver = do
|
||||
AppState { pfreq
|
||||
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls
|
||||
dlinfo <- liftE $ getDownloadInfo GHC ver
|
||||
installGHCBindist dlinfo ver
|
||||
|
||||
|
||||
@ -283,7 +355,10 @@ installGHCBin ver = do
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installCabalBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -310,9 +385,8 @@ installCabalBindist :: ( MonadMask m
|
||||
installCabalBindist dlinfo ver = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
|
||||
AppState { dirs = dirs@Dirs {..}
|
||||
, pfreq = PlatformRequest {..}
|
||||
, settings } <- lift ask
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM
|
||||
(lift (cabalInstalled ver) >>= \a -> liftIO $
|
||||
@ -324,10 +398,10 @@ installCabalBindist dlinfo ver = do
|
||||
(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
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ lift $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
@ -364,7 +438,11 @@ installCabalBindist dlinfo ver = do
|
||||
-- the latest installed version.
|
||||
installCabalBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -388,9 +466,7 @@ installCabalBin :: ( MonadMask m
|
||||
m
|
||||
()
|
||||
installCabalBin ver = do
|
||||
AppState { pfreq
|
||||
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls
|
||||
dlinfo <- liftE $ getDownloadInfo Cabal ver
|
||||
installCabalBindist dlinfo ver
|
||||
|
||||
|
||||
@ -398,7 +474,10 @@ installCabalBin ver = do
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installHLSBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -425,18 +504,17 @@ installHLSBindist :: ( MonadMask m
|
||||
installHLSBindist dlinfo ver = do
|
||||
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
|
||||
|
||||
AppState { dirs = dirs@Dirs {..}
|
||||
, pfreq = PlatformRequest {..}
|
||||
, settings } <- lift ask
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
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
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ lift $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
@ -488,7 +566,11 @@ installHLSBindist dlinfo ver = do
|
||||
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
||||
installHLSBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -512,9 +594,7 @@ installHLSBin :: ( MonadMask m
|
||||
m
|
||||
()
|
||||
installHLSBin ver = do
|
||||
AppState { pfreq
|
||||
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls
|
||||
dlinfo <- liftE $ getDownloadInfo HLS ver
|
||||
installHLSBindist dlinfo ver
|
||||
|
||||
|
||||
@ -523,7 +603,11 @@ installHLSBin ver = do
|
||||
-- the latest installed version.
|
||||
installStackBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -547,8 +631,7 @@ installStackBin :: ( MonadMask m
|
||||
m
|
||||
()
|
||||
installStackBin ver = do
|
||||
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls
|
||||
dlinfo <- liftE $ getDownloadInfo Stack ver
|
||||
installStackBindist dlinfo ver
|
||||
|
||||
|
||||
@ -556,7 +639,10 @@ installStackBin ver = do
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installStackBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@ -583,19 +669,17 @@ installStackBindist :: ( MonadMask m
|
||||
installStackBindist dlinfo ver = do
|
||||
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
|
||||
|
||||
AppState { dirs = dirs@Dirs {..}
|
||||
, pfreq = PlatformRequest {..}
|
||||
, settings
|
||||
} <- lift ask
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (lift (stackInstalled 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
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ lift $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
@ -644,7 +728,8 @@ installStackBindist dlinfo ver = do
|
||||
--
|
||||
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
|
||||
-- for 'SetGHCOnly' constructor.
|
||||
setGHC :: ( MonadReader AppState m
|
||||
setGHC :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -663,7 +748,7 @@ setGHC ver sghc = do
|
||||
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
||||
|
||||
-- symlink destination
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
-- first delete the old symlinks (this fixes compatibility issues
|
||||
-- with old ghcup)
|
||||
@ -701,12 +786,15 @@ setGHC ver sghc = do
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
|
||||
symlinkShareDir :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m)
|
||||
=> FilePath
|
||||
-> String
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir ver' = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let destdir = baseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
@ -733,7 +821,8 @@ setGHC ver sghc = do
|
||||
|
||||
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
|
||||
setCabal :: ( MonadMask m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -745,7 +834,7 @@ setCabal ver = do
|
||||
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
@ -764,7 +853,8 @@ setCabal ver = do
|
||||
|
||||
-- | Set the haskell-language-server symlinks.
|
||||
setHLS :: ( MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -775,7 +865,7 @@ setHLS :: ( MonadCatch m
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setHLS ver = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
-- Delete old symlinks, since these might have different ghc versions than the
|
||||
-- selected version, so we could end up with stray or incorrect symlinks.
|
||||
@ -804,7 +894,8 @@ setHLS ver = do
|
||||
|
||||
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
|
||||
setStack :: ( MonadMask m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -817,7 +908,7 @@ setStack ver = do
|
||||
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
@ -872,7 +963,10 @@ listVersions :: ( MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
)
|
||||
=> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
@ -891,7 +985,7 @@ 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
|
||||
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
||||
-- get versions from GHCupDownloads
|
||||
let avTools = availableToolVersions dls t
|
||||
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
|
||||
@ -917,7 +1011,13 @@ listVersions lt' criteria = do
|
||||
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
|
||||
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
|
||||
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
|
||||
strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
strayGHCs :: ( MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayGHCs avTools = do
|
||||
@ -959,7 +1059,13 @@ listVersions lt' criteria = do
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
strayCabals :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version [Tag]
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
@ -988,7 +1094,12 @@ listVersions lt' criteria = do
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
strayHLS :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayHLS avTools = do
|
||||
@ -1016,7 +1127,13 @@ listVersions lt' criteria = do
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
strayStacks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayStacks avTools = do
|
||||
@ -1045,7 +1162,14 @@ listVersions lt' criteria = do
|
||||
pure Nothing
|
||||
|
||||
-- NOTE: this are not cross ones, because no bindists
|
||||
toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
toListResult :: ( MonadLogger m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasGHCupInfo env
|
||||
, HasPlatformReq env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Tool
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
@ -1056,12 +1180,9 @@ listVersions lt' criteria = do
|
||||
-> (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
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
|
||||
let tver = mkTVer v
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
|
||||
lInstalled <- ghcInstalled tver
|
||||
@ -1069,7 +1190,7 @@ listVersions lt' criteria = do
|
||||
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
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
|
||||
let lSet = cSet == Just v
|
||||
let lInstalled = elem v $ rights cabals
|
||||
pure ListResult { lVer = v
|
||||
@ -1095,7 +1216,7 @@ listVersions lt' criteria = do
|
||||
, ..
|
||||
}
|
||||
HLS -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq dls
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v
|
||||
let lSet = hlsSet' == Just v
|
||||
let lInstalled = elem v $ rights hlses
|
||||
pure ListResult { lVer = v
|
||||
@ -1108,7 +1229,7 @@ listVersions lt' criteria = do
|
||||
, ..
|
||||
}
|
||||
Stack -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq dls
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v
|
||||
let lSet = stackSet' == Just v
|
||||
let lInstalled = elem v $ rights stacks
|
||||
pure ListResult { lVer = v
|
||||
@ -1140,7 +1261,8 @@ listVersions lt' criteria = do
|
||||
-- This may leave GHCup without a "set" version.
|
||||
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
|
||||
-- older version).
|
||||
rmGHCVer :: ( MonadReader AppState m
|
||||
rmGHCVer :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
@ -1181,7 +1303,7 @@ rmGHCVer ver = do
|
||||
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
|
||||
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
@ -1191,7 +1313,8 @@ rmGHCVer ver = do
|
||||
-- | 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
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
@ -1206,7 +1329,7 @@ rmCabalVer ver = do
|
||||
|
||||
cSet <- lift cabalSet
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
|
||||
@ -1221,7 +1344,8 @@ rmCabalVer ver = do
|
||||
-- | 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
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
@ -1236,7 +1360,7 @@ rmHLSVer ver = do
|
||||
|
||||
isHlsSet <- lift hlsSet
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
bins <- lift $ hlsAllBinaries ver
|
||||
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
|
||||
@ -1258,7 +1382,8 @@ 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
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
@ -1273,7 +1398,7 @@ rmStackVer ver = do
|
||||
|
||||
sSet <- lift stackSet
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
|
||||
@ -1286,15 +1411,15 @@ rmStackVer ver = do
|
||||
|
||||
|
||||
-- assuming the current scheme of having just 1 ghcup bin, no version info is required.
|
||||
rmGhcup :: ( MonadReader AppState m
|
||||
rmGhcup :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> m ()
|
||||
|
||||
rmGhcup = do
|
||||
AppState {dirs = Dirs {binDir}} <- ask
|
||||
Dirs {binDir} <- getDirs
|
||||
let ghcupFilename = "ghcup" <> exeExt
|
||||
let ghcupFilepath = binDir </> ghcupFilename
|
||||
|
||||
@ -1338,14 +1463,14 @@ rmGhcup = do
|
||||
<> path <>
|
||||
"\n you may have to uninstall it manually."
|
||||
|
||||
rmTool :: ( MonadReader AppState m
|
||||
, MonadLogger m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m)
|
||||
=> ListResult
|
||||
-> Excepts '[NotInstalled ] m ()
|
||||
|
||||
rmTool :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m)
|
||||
=> ListResult
|
||||
-> Excepts '[NotInstalled ] m ()
|
||||
rmTool ListResult {lVer, lTool, lCross} = do
|
||||
case lTool of
|
||||
GHC ->
|
||||
@ -1357,7 +1482,8 @@ rmTool ListResult {lVer, lTool, lCross} = do
|
||||
GHCup -> lift rmGhcup
|
||||
|
||||
|
||||
rmGhcupDirs :: ( MonadReader AppState m
|
||||
rmGhcupDirs :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadCatch m
|
||||
@ -1369,7 +1495,7 @@ rmGhcupDirs = do
|
||||
, binDir
|
||||
, logsDir
|
||||
, cacheDir
|
||||
} <- asks dirs
|
||||
} <- getDirs
|
||||
|
||||
let envFilePath = baseDir </> "env"
|
||||
|
||||
@ -1477,13 +1603,20 @@ rmGhcupDirs = do
|
||||
------------------
|
||||
|
||||
|
||||
getDebugInfo :: (Alternative m, MonadFail m, MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
getDebugInfo :: ( Alternative m
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
let diBaseDir = baseDir
|
||||
let diBinDir = binDir
|
||||
diGHCDir <- lift ghcupGHCBaseDir
|
||||
@ -1503,7 +1636,11 @@ getDebugInfo = do
|
||||
-- | Compile a GHC from source. This behaves wrt symlinks and installation
|
||||
-- the same as 'installGHCBin'.
|
||||
compileGHC :: ( MonadMask m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasSettings env
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadLogger m
|
||||
@ -1538,10 +1675,9 @@ compileGHC :: ( MonadMask m
|
||||
GHCTargetVersion
|
||||
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
|
||||
= do
|
||||
AppState { pfreq = PlatformRequest {..}
|
||||
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
|
||||
, settings
|
||||
, dirs } <- lift ask
|
||||
PlatformRequest { .. } <- lift getPlatformReq
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
||||
(workdir, tmpUnpack, tver) <- case targetGhc of
|
||||
-- unpack from version tarball
|
||||
Left tver -> do
|
||||
@ -1551,7 +1687,7 @@ 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
|
||||
@ -1618,11 +1754,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
|
||||
Right g -> pure $ Right g
|
||||
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
|
||||
|
||||
(bindist, bmk) <- liftE $ runBuildAction
|
||||
(mBindist, bmk) <- liftE $ runBuildAction
|
||||
tmpUnpack
|
||||
Nothing
|
||||
(do
|
||||
b <- compileBindist bghc tver workdir
|
||||
b <- compileBindist bghc tver workdir ghcdir
|
||||
bmk <- liftIO $ B.readFile (build_mk workdir)
|
||||
pure (b, bmk)
|
||||
)
|
||||
@ -1630,10 +1766,12 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
|
||||
when alreadyInstalled $ do
|
||||
lift $ $(logInfo) [i|Deleting existing installation|]
|
||||
liftE $ rmGHCVer tver
|
||||
liftE $ installPackedGHC bindist
|
||||
(Just $ RegexDir "ghc-.*")
|
||||
ghcdir
|
||||
(tver ^. tvVersion)
|
||||
|
||||
forM_ mBindist $ \bindist -> do
|
||||
liftE $ installPackedGHC bindist
|
||||
(Just $ RegexDir "ghc-.*")
|
||||
ghcdir
|
||||
(tver ^. tvVersion)
|
||||
|
||||
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
|
||||
|
||||
@ -1660,7 +1798,10 @@ BUILD_SPHINX_HTML = NO
|
||||
BUILD_SPHINX_PDF = NO
|
||||
HADDOCK_DOCS = YES|]
|
||||
|
||||
compileBindist :: ( MonadReader AppState m
|
||||
compileBindist :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
@ -1670,15 +1811,17 @@ HADDOCK_DOCS = YES|]
|
||||
=> Either FilePath FilePath
|
||||
-> GHCTargetVersion
|
||||
-> FilePath
|
||||
-> FilePath
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
|
||||
m
|
||||
FilePath -- ^ output path of bindist
|
||||
compileBindist bghc tver workdir = do
|
||||
(Maybe FilePath) -- ^ output path of bindist, None for cross
|
||||
compileBindist bghc tver workdir ghcdir = do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
liftE checkBuildConfig
|
||||
|
||||
AppState { dirs = Dirs {..}, pfreq } <- lift ask
|
||||
|
||||
Dirs {..} <- lift getDirs
|
||||
pfreq <- lift getPlatformReq
|
||||
|
||||
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
|
||||
|
||||
@ -1695,6 +1838,7 @@ HADDOCK_DOCS = YES|]
|
||||
("./configure" : maybe mempty
|
||||
(\x -> ["--target=" <> T.unpack x])
|
||||
(_tvTarget tver)
|
||||
++ ["--prefix=" <> ghcdir]
|
||||
#if defined(IS_WINDOWS)
|
||||
++ ["--enable-tarballs-autodownload"]
|
||||
#endif
|
||||
@ -1711,8 +1855,9 @@ HADDOCK_DOCS = YES|]
|
||||
++ maybe mempty
|
||||
(\x -> ["--target=" <> T.unpack x])
|
||||
(_tvTarget tver)
|
||||
++ ["--prefix=" <> ghcdir]
|
||||
#if defined(IS_WINDOWS)
|
||||
++ ["--enable-tarballs-autodownload"]
|
||||
++ ["--enable-tarballs-autodownload"]
|
||||
#endif
|
||||
++ fmap T.unpack aargs
|
||||
)
|
||||
@ -1731,30 +1876,35 @@ HADDOCK_DOCS = YES|]
|
||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
|
||||
|
||||
lift $ $(logInfo) [i|Creating bindist...|]
|
||||
lEM $ make ["binary-dist"] (Just workdir)
|
||||
[tar] <- liftIO $ findFiles
|
||||
workdir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^ghc-.*\.tar\..*$|] :: ByteString)
|
||||
)
|
||||
c <- liftIO $ BL.readFile (workdir </> tar)
|
||||
cDigest <-
|
||||
fmap (T.take 8)
|
||||
. lift
|
||||
. throwEither
|
||||
. E.decodeUtf8'
|
||||
. B16.encode
|
||||
. SHA256.hashlazy
|
||||
$ c
|
||||
cTime <- liftIO getCurrentTime
|
||||
let tarName = makeValid [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
|
||||
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
|
||||
pure tarPath
|
||||
if | isCross tver -> do
|
||||
lift $ $(logInfo) [i|Installing cross toolchain...|]
|
||||
lEM $ make ["install"] (Just workdir)
|
||||
pure Nothing
|
||||
| otherwise -> do
|
||||
lift $ $(logInfo) [i|Creating bindist...|]
|
||||
lEM $ make ["binary-dist"] (Just workdir)
|
||||
[tar] <- liftIO $ findFiles
|
||||
workdir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^ghc-.*\.tar\..*$|] :: ByteString)
|
||||
)
|
||||
c <- liftIO $ BL.readFile (workdir </> tar)
|
||||
cDigest <-
|
||||
fmap (T.take 8)
|
||||
. lift
|
||||
. throwEither
|
||||
. E.decodeUtf8'
|
||||
. B16.encode
|
||||
. SHA256.hashlazy
|
||||
$ c
|
||||
cTime <- liftIO getCurrentTime
|
||||
let tarName = makeValid [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
|
||||
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
|
||||
pure $ Just tarPath
|
||||
|
||||
build_mk workdir = workdir </> "mk" </> "build.mk"
|
||||
|
||||
@ -1781,6 +1931,9 @@ HADDOCK_DOCS = YES|]
|
||||
)
|
||||
_ -> pure ()
|
||||
|
||||
isCross :: GHCTargetVersion -> Bool
|
||||
isCross = isJust . _tvTarget
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1792,7 +1945,11 @@ HADDOCK_DOCS = YES|]
|
||||
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
|
||||
-- if no path is provided.
|
||||
upgradeGHCup :: ( MonadMask m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
@ -1813,17 +1970,16 @@ upgradeGHCup :: ( MonadMask m
|
||||
m
|
||||
Version
|
||||
upgradeGHCup mtarget force' = do
|
||||
AppState { dirs = Dirs {..}
|
||||
, pfreq
|
||||
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
|
||||
, settings } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
||||
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
|
||||
dli <- liftE $ getDownloadInfo GHCup latestVer
|
||||
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 <> exeExt) mtarget
|
||||
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
|
||||
@ -1865,7 +2021,8 @@ upgradeGHCup mtarget force' = do
|
||||
|
||||
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
|
||||
-- both installing from source and bindist.
|
||||
postGHCInstall :: ( MonadReader AppState m
|
||||
postGHCInstall :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -1896,7 +2053,8 @@ postGHCInstall ver@GHCTargetVersion {..} = do
|
||||
-- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@
|
||||
-- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@
|
||||
-- * for ghcup, this reports the location of the currently running executable
|
||||
whereIsTool :: ( MonadReader AppState m
|
||||
whereIsTool :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -1909,14 +2067,14 @@ whereIsTool :: ( MonadReader AppState m
|
||||
-> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m FilePath
|
||||
whereIsTool tool ver@GHCTargetVersion {..} = do
|
||||
AppState { dirs } <- lift ask
|
||||
dirs <- lift getDirs
|
||||
|
||||
case tool of
|
||||
GHC -> do
|
||||
whenM (lift $ fmap not $ ghcInstalled ver)
|
||||
$ throwE (NotInstalled GHC ver)
|
||||
bdir <- lift $ ghcupGHCDir ver
|
||||
pure (bdir </> "bin" </> "ghc" <> exeExt)
|
||||
pure (bdir </> "bin" </> ghcBinaryName ver)
|
||||
Cabal -> do
|
||||
whenM (lift $ fmap not $ cabalInstalled _tvVersion)
|
||||
$ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion))
|
||||
@ -1933,3 +2091,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
|
||||
GHCup -> do
|
||||
currentRunningExecPath <- liftIO getExecutablePath
|
||||
liftIO $ canonicalizePath currentRunningExecPath
|
||||
|
||||
|
||||
|
||||
|
||||
@ -107,32 +107,31 @@ import qualified Data.Yaml as Y
|
||||
getDownloadsF :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Settings
|
||||
-> Dirs
|
||||
-> Excepts
|
||||
=> Excepts
|
||||
'[JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
m
|
||||
GHCupInfo
|
||||
getDownloadsF settings@Settings{ urlSource } dirs = do
|
||||
getDownloadsF = do
|
||||
Settings { urlSource } <- lift getSettings
|
||||
case urlSource of
|
||||
GHCupURL -> liftE $ getBase dirs settings
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
|
||||
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
|
||||
GHCupURL -> liftE $ getBase ghcupURL
|
||||
(OwnSource url) -> liftE $ getBase url
|
||||
(OwnSpec av) -> pure av
|
||||
(AddSource (Left ext)) -> do
|
||||
base <- liftE $ getBase dirs settings
|
||||
base <- liftE $ getBase ghcupURL
|
||||
pure (mergeGhcupInfo base ext)
|
||||
(AddSource (Right uri)) -> do
|
||||
base <- liftE $ getBase dirs settings
|
||||
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
|
||||
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
|
||||
base <- liftE $ getBase ghcupURL
|
||||
ext <- liftE $ getBase uri
|
||||
pure (mergeGhcupInfo base ext)
|
||||
|
||||
where
|
||||
@ -149,33 +148,49 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
|
||||
in GHCupInfo tr newDownloads newGlobalTools
|
||||
|
||||
|
||||
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
|
||||
=> Dirs
|
||||
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
|
||||
readFromCache Dirs {..} = do
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
$ liftIO
|
||||
$ L.readFile yaml_file
|
||||
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
|
||||
readFromCache :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m)
|
||||
=> URI
|
||||
-> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
|
||||
readFromCache uri = do
|
||||
Dirs{..} <- lift getDirs
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
|
||||
handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
. liftIO
|
||||
. L.readFile
|
||||
$ yaml_file
|
||||
|
||||
|
||||
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
|
||||
=> Dirs
|
||||
-> Settings
|
||||
getBase :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> URI
|
||||
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
|
||||
getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
handleIO (\_ -> readFromCache dirs)
|
||||
$ catchE @_ @'[JSONError, FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache dirs)
|
||||
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
|
||||
where
|
||||
getBase uri = do
|
||||
Settings { noNetwork } <- lift getSettings
|
||||
bs <- if noNetwork
|
||||
then readFromCache uri
|
||||
else handleIO (\_ -> warnCache >> readFromCache uri)
|
||||
. catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
|
||||
. reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
|
||||
$ smartDl uri
|
||||
liftE
|
||||
. lE' @_ @_ @'[JSONError] JSONDecodeError
|
||||
. first show
|
||||
. Y.decodeEither'
|
||||
. L.toStrict
|
||||
$ bs
|
||||
where
|
||||
warnCache = lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
@ -185,8 +200,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
-- than the local file.
|
||||
--
|
||||
-- Always save the local file with the mod time of the remote file.
|
||||
smartDl :: forall m1
|
||||
. ( MonadCatch m1
|
||||
smartDl :: forall m1 env1
|
||||
. ( MonadReader env1 m1
|
||||
, HasDirs env1
|
||||
, HasSettings env1
|
||||
, MonadCatch m1
|
||||
, MonadIO m1
|
||||
, MonadFail m1
|
||||
, MonadLogger m1
|
||||
@ -200,13 +218,15 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
, NoNetwork
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
smartDl uri' = do
|
||||
Dirs{..} <- lift getDirs
|
||||
let path = view pathL' uri'
|
||||
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <- liftIO $ getAccessTime json_file
|
||||
@ -237,11 +257,11 @@ 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'
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ hideError doesNotExistErrorType $ rmFile json_file
|
||||
liftIO $ L.writeFile json_file bs
|
||||
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
@ -279,39 +299,46 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
setModificationTime path utctime
|
||||
|
||||
|
||||
getDownloadInfo :: Tool
|
||||
getDownloadInfo :: ( MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
)
|
||||
=> Tool
|
||||
-> Version
|
||||
-- ^ tool version
|
||||
-> PlatformRequest
|
||||
-> GHCupDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(case p of
|
||||
-- non-musl won't work on alpine
|
||||
Linux Alpine -> with_distro <|> without_distro_ver
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
-> Excepts
|
||||
'[NoDownload]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo t v = do
|
||||
(PlatformRequest a p mv) <- lift getPlatformReq
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
let distro_preview f g =
|
||||
let platformVersionSpec =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
|
||||
mv' = g mv
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(isNothing mv')
|
||||
(\range -> maybe False (`versionRange` range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
=<< platformVersionSpec
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
let platformVersionSpec =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
|
||||
mv' = g mv
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(isNothing mv')
|
||||
(\range -> maybe False (`versionRange` range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
=<< platformVersionSpec
|
||||
maybe
|
||||
(throwE NoDownload)
|
||||
pure
|
||||
(case p of
|
||||
-- non-musl won't work on alpine
|
||||
Linux Alpine -> with_distro <|> without_distro_ver
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
@ -321,17 +348,19 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
-- 2. otherwise create a random file
|
||||
--
|
||||
-- The file must not exist.
|
||||
download :: ( MonadMask m
|
||||
download :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadMask 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
|
||||
@ -362,6 +391,8 @@ download settings@Settings{ downloader } dli dest mfn
|
||||
liftIO (hideError doesNotExistErrorType $ rmFile destFile)
|
||||
>> (throwE . DownloadFailed $ e)
|
||||
) $ do
|
||||
Settings{ downloader, noNetwork } <- lift getSettings
|
||||
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
|
||||
case downloader of
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
@ -377,58 +408,66 @@ 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.
|
||||
getDestFile :: FilePath
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
|
||||
(dest </>)
|
||||
mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
path = view (dlUri % pathL') dli
|
||||
|
||||
|
||||
-- | Download into tmpdir or use cached version, if it exists. If filename
|
||||
-- is omitted, infers the filename from the url.
|
||||
downloadCached :: ( MonadMask m
|
||||
downloadCached :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadMask m
|
||||
, MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO 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
|
||||
Settings{ cache } <- lift getSettings
|
||||
case cache of
|
||||
True -> downloadCached' settings dirs dli mfn
|
||||
True -> downloadCached' dli mfn Nothing
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download settings dli tmp mfn
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
|
||||
downloadCached' :: ( MonadMask m
|
||||
downloadCached' :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Settings
|
||||
-> Dirs
|
||||
-> DownloadInfo
|
||||
=> DownloadInfo
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
downloadCached' settings Dirs{..} dli mfn = do
|
||||
downloadCached' dli mfn mDestDir = do
|
||||
Dirs { cacheDir } <- lift getDirs
|
||||
let destDir = fromMaybe cacheDir mDestDir
|
||||
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
|
||||
let cachfile = cacheDir </> fn
|
||||
let cachfile = destDir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest settings dli cachfile
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure cachfile
|
||||
| otherwise -> liftE $ download settings dli cacheDir mfn
|
||||
| otherwise -> liftE $ download dli destDir mfn
|
||||
|
||||
|
||||
|
||||
@ -441,9 +480,13 @@ downloadCached' settings Dirs{..} dli mfn = do
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
|
||||
=> Downloader
|
||||
-> URI
|
||||
downloadBS :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
@ -452,10 +495,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
, NoNetwork
|
||||
]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS downloader uri'
|
||||
downloadBS uri'
|
||||
| scheme == "https"
|
||||
= dl True
|
||||
| scheme == "http"
|
||||
@ -475,6 +519,8 @@ downloadBS downloader uri'
|
||||
dl _ = do
|
||||
#endif
|
||||
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
|
||||
Settings{ downloader, noNetwork } <- lift getSettings
|
||||
when noNetwork $ throwE NoNetwork
|
||||
case downloader of
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
@ -499,12 +545,18 @@ downloadBS downloader uri'
|
||||
#endif
|
||||
|
||||
|
||||
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
|
||||
=> Settings
|
||||
-> DownloadInfo
|
||||
checkDigest :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> FilePath
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest Settings{ noVerify } dli file = do
|
||||
checkDigest dli file = do
|
||||
Settings{ noVerify } <- lift getSettings
|
||||
let verify = not noVerify
|
||||
when verify $ do
|
||||
let p' = takeFileName file
|
||||
|
||||
@ -233,6 +233,13 @@ instance Pretty NoToolVersionSet where
|
||||
pPrint (NoToolVersionSet tool) =
|
||||
text [i|No version is set for tool "#{tool}".|]
|
||||
|
||||
data NoNetwork = NoNetwork
|
||||
deriving Show
|
||||
|
||||
instance Pretty NoNetwork where
|
||||
pPrint NoNetwork =
|
||||
text [i|A download was required or requested, but '--offline' was specified.|]
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ High-level errors ]--
|
||||
|
||||
@ -1,9 +1,12 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
@ -294,11 +297,12 @@ data UserSettings = UserSettings
|
||||
, uDownloader :: Maybe Downloader
|
||||
, uKeyBindings :: Maybe UserKeyBindings
|
||||
, uUrlSource :: Maybe URLSource
|
||||
, uNoNetwork :: Maybe Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
{ kUp :: Maybe Key
|
||||
@ -346,12 +350,21 @@ data AppState = AppState
|
||||
{ settings :: Settings
|
||||
, dirs :: Dirs
|
||||
, keyBindings :: KeyBindings
|
||||
, ghcupInfo :: ~GHCupInfo
|
||||
, pfreq :: ~PlatformRequest
|
||||
, ghcupInfo :: GHCupInfo
|
||||
, pfreq :: PlatformRequest
|
||||
} deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData AppState
|
||||
|
||||
data LeanAppState = LeanAppState
|
||||
{ settings :: Settings
|
||||
, dirs :: Dirs
|
||||
, keyBindings :: KeyBindings
|
||||
} deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData LeanAppState
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, noVerify :: Bool
|
||||
@ -359,6 +372,7 @@ data Settings = Settings
|
||||
, downloader :: Downloader
|
||||
, verbose :: Bool
|
||||
, urlSource :: URLSource
|
||||
, noNetwork :: Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
@ -507,4 +521,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where
|
||||
instance MonadLogger m => MonadLogger (Excepts e m) where
|
||||
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
|
||||
|
||||
|
||||
|
||||
@ -1,4 +1,9 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types.Optics
|
||||
@ -13,6 +18,7 @@ module GHCup.Types.Optics where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString ( ByteString )
|
||||
import Optics
|
||||
import URI.ByteString
|
||||
@ -58,3 +64,82 @@ pathL' = lensVL pathL
|
||||
|
||||
queryL' :: Lens' (URIRef a) Query
|
||||
queryL' = lensVL queryL
|
||||
|
||||
|
||||
|
||||
----------------------
|
||||
--[ Lens utilities ]--
|
||||
----------------------
|
||||
|
||||
|
||||
gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
|
||||
=> m a
|
||||
gets = asks (^. labelOptic @f)
|
||||
|
||||
|
||||
getAppState :: MonadReader AppState m => m AppState
|
||||
getAppState = ask
|
||||
|
||||
|
||||
getLeanAppState :: ( MonadReader env m
|
||||
, LabelOptic' "settings" A_Lens env Settings
|
||||
, LabelOptic' "dirs" A_Lens env Dirs
|
||||
, LabelOptic' "keyBindings" A_Lens env KeyBindings
|
||||
)
|
||||
=> m LeanAppState
|
||||
getLeanAppState = do
|
||||
s <- gets @"settings"
|
||||
d <- gets @"dirs"
|
||||
k <- gets @"keyBindings"
|
||||
pure (LeanAppState s d k)
|
||||
|
||||
|
||||
getSettings :: ( MonadReader env m
|
||||
, LabelOptic' "settings" A_Lens env Settings
|
||||
)
|
||||
=> m Settings
|
||||
getSettings = gets @"settings"
|
||||
|
||||
|
||||
getDirs :: ( MonadReader env m
|
||||
, LabelOptic' "dirs" A_Lens env Dirs
|
||||
)
|
||||
=> m Dirs
|
||||
getDirs = gets @"dirs"
|
||||
|
||||
|
||||
getKeyBindings :: ( MonadReader env m
|
||||
, LabelOptic' "keyBindings" A_Lens env KeyBindings
|
||||
)
|
||||
=> m KeyBindings
|
||||
getKeyBindings = gets @"keyBindings"
|
||||
|
||||
|
||||
getGHCupInfo :: ( MonadReader env m
|
||||
, LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
|
||||
)
|
||||
=> m GHCupInfo
|
||||
getGHCupInfo = gets @"ghcupInfo"
|
||||
|
||||
|
||||
getPlatformReq :: ( MonadReader env m
|
||||
, LabelOptic' "pfreq" A_Lens env PlatformRequest
|
||||
)
|
||||
=> m PlatformRequest
|
||||
getPlatformReq = gets @"pfreq"
|
||||
|
||||
|
||||
type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
|
||||
type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
|
||||
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
|
||||
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
|
||||
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
|
||||
|
||||
|
||||
getCache :: (MonadReader env m, HasSettings env) => m Bool
|
||||
getCache = getSettings <&> cache
|
||||
|
||||
|
||||
getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
|
||||
getDownloader = getSettings <&> downloader
|
||||
|
||||
|
||||
@ -103,28 +103,30 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
ghcLinkDestination :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m, MonadIO m)
|
||||
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> GHCTargetVersion
|
||||
-> m FilePath
|
||||
ghcLinkDestination tool ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
ghcd <- ghcupGHCDir ver
|
||||
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
|
||||
|
||||
|
||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
||||
rmMinorSymlinks :: ( MonadReader AppState m
|
||||
rmMinorSymlinks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
||||
|
||||
|
||||
-- | Removes the set ghc version for the given target, if any.
|
||||
rmPlain :: ( MonadReader AppState m
|
||||
rmPlain :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m
|
||||
=> Maybe Text -- ^ target
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain target = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
mtv <- lift $ ghcSet target
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
@ -159,17 +162,17 @@ rmPlain target = do
|
||||
|
||||
|
||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
||||
rmMajorSymlinks :: ( MonadReader AppState m
|
||||
rmMajorSymlinks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
(mj, mi) <- getMajorMinorV _tvVersion
|
||||
let v' = intToText mj <> "." <> intToText mi
|
||||
|
||||
@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
||||
|
||||
|
||||
-- | Whether the given GHC versin is installed.
|
||||
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
liftIO $ doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
-- | Whether the given GHC version is installed from source.
|
||||
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcSrcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
-- | Whether the given GHC version is set as the current.
|
||||
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
||||
=> Maybe Text -- ^ the target of the GHC version, if any
|
||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
ghcSet mtarget = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
|
||||
let ghcBin = binDir </> ghc <> exeExt
|
||||
|
||||
@ -239,7 +242,7 @@ ghcSet mtarget = do
|
||||
|
||||
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
|
||||
-- If a dir cannot be parsed, returns left.
|
||||
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||
getInstalledGHCs = do
|
||||
ghcdir <- ghcupGHCBaseDir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
|
||||
@ -249,10 +252,15 @@ getInstalledGHCs = do
|
||||
|
||||
|
||||
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
||||
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
getInstalledCabals :: ( MonadLogger m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledCabals = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
|
||||
@ -264,16 +272,16 @@ getInstalledCabals = do
|
||||
|
||||
|
||||
-- | Whether the given cabal version is installed.
|
||||
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled ver = do
|
||||
vers <- fmap rights getInstalledCabals
|
||||
pure $ elem ver vers
|
||||
|
||||
|
||||
-- Return the currently set cabal version, if any.
|
||||
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
|
||||
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
@ -317,10 +325,10 @@ cabalSet = do
|
||||
|
||||
-- | Get all installed hls, by matching on
|
||||
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
|
||||
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledHLSs = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
@ -337,10 +345,10 @@ getInstalledHLSs = do
|
||||
|
||||
-- | Get all installed stacks, by matching on
|
||||
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
|
||||
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledStacks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
@ -355,9 +363,9 @@ getInstalledStacks = do
|
||||
|
||||
-- Return the currently set stack version, if any.
|
||||
-- TODO: there's a lot of code duplication here :>
|
||||
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
|
||||
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
|
||||
stackSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let stackBin = binDir </> "stack" <> exeExt
|
||||
|
||||
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
@ -395,13 +403,13 @@ stackSet = do
|
||||
stripRelativePath = MP.many (MP.try stripPathComponet)
|
||||
|
||||
-- | Whether the given Stack version is installed.
|
||||
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
stackInstalled ver = do
|
||||
vers <- fmap rights getInstalledStacks
|
||||
pure $ elem ver vers
|
||||
|
||||
-- | Whether the given HLS version is installed.
|
||||
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled ver = do
|
||||
vers <- fmap rights getInstalledHLSs
|
||||
pure $ elem ver vers
|
||||
@ -409,9 +417,9 @@ hlsInstalled ver = do
|
||||
|
||||
|
||||
-- Return the currently set hls version, if any.
|
||||
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
@ -443,7 +451,8 @@ hlsSet = do
|
||||
|
||||
|
||||
-- | Return the GHC versions the currently selected HLS supports.
|
||||
hlsGHCVersions :: ( MonadReader AppState m
|
||||
hlsGHCVersions :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
@ -466,11 +475,11 @@ hlsGHCVersions = do
|
||||
|
||||
|
||||
-- | Get all server binaries for an hls version, if any.
|
||||
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
|
||||
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> Version
|
||||
-> m [FilePath]
|
||||
hlsServerBinaries ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
@ -482,12 +491,12 @@ hlsServerBinaries ver = do
|
||||
|
||||
|
||||
-- | Get the wrapper binary for an hls version, if any.
|
||||
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
||||
=> Version
|
||||
-> m (Maybe FilePath)
|
||||
hlsWrapperBinary ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
Dirs {..} <- getDirs
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
@ -503,7 +512,7 @@ hlsWrapperBinary ver = do
|
||||
|
||||
|
||||
-- | Get all binaries for an hls version, if any.
|
||||
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries ver = do
|
||||
hls <- hlsServerBinaries ver
|
||||
wrapper <- hlsWrapperBinary ver
|
||||
@ -511,9 +520,9 @@ hlsAllBinaries ver = do
|
||||
|
||||
|
||||
-- | Get the active symlinks for hls.
|
||||
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
|
||||
hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
|
||||
hlsSymlinks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
@ -549,7 +558,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> Maybe Text -- ^ the target triple
|
||||
@ -729,19 +738,6 @@ getLatestBaseVersion av pvpVer =
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
--[ AppState Getter ]--
|
||||
-----------------------
|
||||
|
||||
|
||||
getCache :: MonadReader AppState m => m Bool
|
||||
getCache = ask <&> cache . settings
|
||||
|
||||
|
||||
getDownloader :: MonadReader AppState m => m Downloader
|
||||
getDownloader = ask <&> downloader . settings
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings
|
||||
-- Returns unversioned relative files without extension, e.g.:
|
||||
--
|
||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
||||
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m [FilePath]
|
||||
ghcToolFiles ver = do
|
||||
@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built"
|
||||
|
||||
|
||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
|
||||
make :: ( MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
)
|
||||
=> [String]
|
||||
-> Maybe FilePath
|
||||
-> m (Either ProcessError ())
|
||||
@ -827,7 +828,7 @@ 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)
|
||||
makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> [String]
|
||||
-> Maybe FilePath
|
||||
-> m CapturedProcess
|
||||
@ -840,7 +841,7 @@ makeOut args workdir = do
|
||||
|
||||
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
||||
-- on first failure.
|
||||
applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m)
|
||||
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
|
||||
=> FilePath -- ^ dir containing patches
|
||||
-> FilePath -- ^ dir to apply patches in
|
||||
-> Excepts '[PatchFailed] m ()
|
||||
@ -858,7 +859,7 @@ applyPatches pdir ddir = do
|
||||
|
||||
|
||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
||||
darwinNotarization :: (MonadReader AppState m, MonadIO m)
|
||||
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> Platform
|
||||
-> FilePath
|
||||
-> m (Either ProcessError ())
|
||||
@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) =
|
||||
--
|
||||
-- 1. the build directory, depending on the KeepDirs setting
|
||||
-- 2. the install destination, depending on whether the build failed
|
||||
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
|
||||
runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
|
||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Maybe FilePath -- ^ dir to *always* clean up on exception
|
||||
-> Excepts e m a
|
||||
-> Excepts '[BuildFailed] m a
|
||||
runBuildAction bdir instdir action = do
|
||||
AppState { settings = Settings {..} } <- lift ask
|
||||
Settings {..} <- lift getSettings
|
||||
let exAction = do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ rmPath dir
|
||||
@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m
|
||||
-> m ()
|
||||
createLink link exe = do
|
||||
#if defined(IS_WINDOWS)
|
||||
AppState { dirs } <- ask
|
||||
dirs <- getDirs
|
||||
let shimGen = cacheDir dirs </> "gs.exe"
|
||||
|
||||
let shim = dropExtension exe <.> "shim"
|
||||
@ -1054,17 +1056,22 @@ ensureGlobalTools :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasGHCupInfo env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
|
||||
ensureGlobalTools = do
|
||||
#if defined(IS_WINDOWS)
|
||||
AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask
|
||||
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
|
||||
settings <- lift getSettings
|
||||
dirs <- lift getDirs
|
||||
shimDownload <- liftE $ lE @_ @'[NoDownload]
|
||||
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
|
||||
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe")
|
||||
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
|
||||
void $ (\(DigestError _ _) -> do
|
||||
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
|
||||
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
|
||||
@ -1093,3 +1100,16 @@ ensureDirectories dirs = do
|
||||
createDirRecursive' logsDir
|
||||
createDirRecursive' confDir
|
||||
pure ()
|
||||
|
||||
|
||||
-- | For ghc without arch triple, this is:
|
||||
--
|
||||
-- - ghc-<ver> (e.g. ghc-8.10.4)
|
||||
--
|
||||
-- For ghc with arch triple:
|
||||
--
|
||||
-- - <triple>-ghc-<ver> (e.g. arm-linux-gnueabihf-ghc-8.10.4)
|
||||
ghcBinaryName :: GHCTargetVersion -> String
|
||||
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
|
||||
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
|
||||
|
||||
|
||||
@ -16,7 +16,7 @@ Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.Dirs
|
||||
( getDirs
|
||||
( getAllDirs
|
||||
, ghcupBaseDir
|
||||
, ghcupConfigFile
|
||||
, ghcupCacheDir
|
||||
@ -37,6 +37,7 @@ where
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
@ -190,8 +191,8 @@ ghcupLogsDir = do
|
||||
#endif
|
||||
|
||||
|
||||
getDirs :: IO Dirs
|
||||
getDirs = do
|
||||
getAllDirs :: IO Dirs
|
||||
getAllDirs = do
|
||||
baseDir <- ghcupBaseDir
|
||||
binDir <- ghcupBinDir
|
||||
cacheDir <- ghcupCacheDir
|
||||
@ -226,9 +227,9 @@ ghcupConfigFile = do
|
||||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
|
||||
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
|
||||
ghcupGHCBaseDir = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
pure (baseDir </> "ghc")
|
||||
|
||||
|
||||
@ -236,7 +237,7 @@ ghcupGHCBaseDir = do
|
||||
-- The dir may be of the form
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
-- * 8.8.4
|
||||
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
|
||||
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
||||
=> GHCTargetVersion
|
||||
-> m FilePath
|
||||
ghcupGHCDir ver = do
|
||||
|
||||
@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
|
||||
SPP.executeFile path True args Nothing
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
|
||||
Settings {..} <- getSettings
|
||||
Dirs {..} <- getDirs
|
||||
let logfile = logsDir </> lfile <> ".log"
|
||||
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
||||
closeFd
|
||||
|
||||
@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
@ -146,7 +147,11 @@ executeOut path args chdir = do
|
||||
pure $ CapturedProcess exit out err
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
@ -154,7 +159,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = logsDir </> lfile <> ".stderr.log"
|
||||
cp <- createProcessWithMingwPath ((proc exe args)
|
||||
|
||||
@ -31,6 +31,10 @@ extra-deps:
|
||||
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
|
||||
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
|
||||
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
|
||||
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
|
||||
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
|
||||
- optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
|
||||
- optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
|
||||
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
|
||||
- regex-posix-clib-2.7
|
||||
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
|
||||
|
||||
Loading…
Reference in New Issue
Block a user