Compare commits

..

1 Commits

Author SHA1 Message Date
f60e1d1624 Use ghc-debug 2022-06-11 15:30:52 +02:00
25 changed files with 236 additions and 551 deletions

View File

@@ -97,23 +97,17 @@ rm -rf "${GHCUP_DIR}"
eghcup --numeric-version eghcup --numeric-version
eghcup install ghc ${GHC_VERSION} eghcup install ghc ${GHC_VERSION}
eghcup unset ghc ${GHC_VERSION}
ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})" ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})"
[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ] [ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ]
[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ] [ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ]
[ "`ghcup run --ghc ${GHC_VERSION} -- ghc -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" = "`$(ghcup whereis ghc ${GHC_VERSION}) -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" ]
eghcup set ghc ${GHC_VERSION} eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION} eghcup install cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] [ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
eghcup unset cabal eghcup unset cabal
"$GHCUP_BIN"/cabal --version && exit 1 || echo yes "$GHCUP_BIN"/cabal --version && exit 1 || echo yes
# make sure no cabal is set when running 'ghcup run' to check that PATH propagages properly
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
eghcup set cabal ${CABAL_VERSION} eghcup set cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] [ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
if [ "${OS}" != "FREEBSD" ] ; then if [ "${OS}" != "FREEBSD" ] ; then
if [ "${ARCH}" = "64" ] ; then if [ "${ARCH}" = "64" ] ; then

View File

@@ -71,16 +71,15 @@ changelogP =
"cabal" -> Right Cabal "cabal" -> Right Cabal
"ghcup" -> Right GHCup "ghcup" -> Right GHCup
"stack" -> Right Stack "stack" -> Right Stack
"hls" -> Right HLS
e -> Left e e -> Left e
) )
) )
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup>" <> help (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)" "Open changelog for given tool (default: ghc)"
<> completer toolCompleter <> completer toolCompleter
) )
) )
<*> optional (toolVersionTagArgument Nothing Nothing) <*> optional (toolVersionArgument Nothing Nothing)
@@ -117,8 +116,7 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
ver' = maybe ver' = maybe
(Right Latest) (Right Latest)
(\case (\case
GHCVersion tv -> Left (_tvVersion tv) ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion
ToolVersion tv -> Left tv
ToolTag t -> Right t ToolTag t -> Right t
) )
clToolVer clToolVer

View File

@@ -70,24 +70,20 @@ import Control.Exception (evaluate)
--[ Types ]-- --[ Types ]--
------------- -------------
data ToolVersion = GHCVersion GHCTargetVersion data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolVersion Version
| ToolTag Tag | ToolTag Tag
-- a superset of ToolVersion -- a superset of ToolVersion
data SetToolVersion = SetGHCVersion GHCTargetVersion data SetToolVersion = SetToolVersion GHCTargetVersion
| SetToolVersion Version
| SetToolTag Tag | SetToolTag Tag
| SetRecommended | SetRecommended
| SetNext | SetNext
prettyToolVer :: ToolVersion -> String prettyToolVer :: ToolVersion -> String
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'
prettyToolVer (ToolTag t) = show t prettyToolVer (ToolTag t) = show t
toSetToolVer :: Maybe ToolVersion -> SetToolVersion toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t' toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer Nothing = SetRecommended toSetToolVer Nothing = SetRecommended
@@ -100,9 +96,10 @@ toSetToolVer Nothing = SetRecommended
-------------- --------------
toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion -- | same as toolVersionParser, except as an argument.
toolVersionTagArgument criteria tool = toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
argument (eitherReader (parser tool)) toolVersionArgument criteria tool =
argument (eitherReader toolVersionEither)
(metavar (mv tool) (metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) []) <> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool) <> foldMap (completer . versionCompleter criteria) tool)
@@ -111,19 +108,20 @@ toolVersionTagArgument criteria tool =
mv (Just HLS) = "HLS_VERSION|TAG" mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG" mv _ = "VERSION|TAG"
parser (Just GHC) = ghcVersionTagEither
parser Nothing = ghcVersionTagEither
parser _ = toolVersionTagEither
versionParser :: Parser GHCTargetVersion
versionParser = option
(eitherReader tVersionEither)
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack)) (eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither) versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
-- https://github.com/pcapriotti/optparse-applicative/issues/148 -- https://github.com/pcapriotti/optparse-applicative/issues/148
@@ -232,15 +230,9 @@ isolateParser f = case isValid f && isAbsolute f of
True -> Right $ normalise f True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir." False -> Left "Please enter a valid filepath for isolate dir."
-- this accepts cross prefix toolVersionEither :: String -> Either String ToolVersion
ghcVersionTagEither :: String -> Either String ToolVersion toolVersionEither s' =
ghcVersionTagEither s' = second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')
-- this ignores cross prefix
toolVersionTagEither :: String -> Either String ToolVersion
toolVersionTagEither s' =
second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')
tagEither :: String -> Either String Tag tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of tagEither s' = case fmap toLower s' of
@@ -252,14 +244,10 @@ tagEither s' = case fmap toLower s' of
other -> Left $ "Unknown tag " <> other other -> Left $ "Unknown tag " <> other
ghcVersionEither :: String -> Either String GHCTargetVersion tVersionEither :: String -> Either String GHCTargetVersion
ghcVersionEither = tVersionEither =
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
toolVersionEither :: String -> Either String Version
toolVersionEither =
first (const "Not a valid version") . MP.parse version' "" . T.pack
toolParser :: String -> Either String Tool toolParser :: String -> Either String Tool
toolParser s' | t == T.pack "ghc" = Right GHC toolParser s' | t == T.pack "ghc" = Right GHC
@@ -675,7 +663,7 @@ fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool bimap mkTVer Just <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
@@ -687,18 +675,6 @@ fromVersion' (SetGHCVersion v) tool = do
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi') pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls
case pvp $ prettyVer v of -- need to be strict here
Left _ -> pure (mkTVer v, vi)
Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_ ""
when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mempty v', Just vi')
Nothing -> pure (mkTVer v, vi)
fromVersion' (SetToolTag Latest) tool = do fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool

View File

@@ -82,7 +82,7 @@ data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: Either Version GitBranch { targetHLS :: Either Version GitBranch
, jobs :: Maybe Int , jobs :: Maybe Int
, setCompile :: Bool , setCompile :: Bool
, ovewrwiteVer :: Either Bool Version , ovewrwiteVer :: Maybe Version
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, cabalProject :: Maybe (Either FilePath URI) , cabalProject :: Maybe (Either FilePath URI)
, cabalProjectLocal :: Maybe URI , cabalProjectLocal :: Maybe URI
@@ -145,16 +145,14 @@ Examples:
compileHLSFooter = [s|Discussion: compileHLSFooter = [s|Discussion:
Compiles and installs the specified HLS version. Compiles and installs the specified HLS version.
The --ghc arguments are necessary to specify which GHC version to build for/against. The last argument is a list of GHC versions to compile for.
These need to be available in PATH prior to compilation. These need to be available in PATH prior to compilation.
Examples: Examples:
# compile 1.7.0.0 for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal # compile 1.4.0 for ghc 8.10.5 and 8.10.7
ghcup compile hls -v 1.7.0.0 -j 12 --ghc 8.10.5 --ghc 8.10.7 -- --allow-newer ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7
# compile from master for ghc 9.2.3 and use 'git describe' to name the binary # compile from master for ghc 8.10.7, linking everything dynamically
ghcup compile hls -g master --git-describe-version --ghc 9.2.3 ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]
# compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name
ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]
ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts :: Parser GHCCompileOptions
@@ -282,7 +280,7 @@ hlsCompileOpts =
(Right <$> (GitBranch <$> option (Right <$> (GitBranch <$> option
str str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)" "The git commit/branch/ref to build from"
) <*> ) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)" optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
<> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"]) <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
@@ -297,9 +295,8 @@ hlsCompileOpts =
) )
) )
<*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install")) <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
<*> <*> optional
( (option
(Right <$> option
(eitherReader (eitherReader
(first (const "Not a valid version") . version . T.pack) (first (const "Not a valid version") . version . T.pack)
) )
@@ -308,14 +305,6 @@ hlsCompileOpts =
<> (completer $ versionCompleter Nothing HLS) <> (completer $ versionCompleter Nothing HLS)
) )
) )
<|>
(Left <$> (switch
(long "git-describe-version"
<> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."
)
)
)
)
<*> optional <*> optional
(option (option
(eitherReader isolateParser) (eitherReader isolateParser)
@@ -362,7 +351,7 @@ hlsCompileOpts =
) )
) )
<*> some ( <*> some (
option (eitherReader ghcVersionTagEither) option (eitherReader toolVersionEither)
( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)" ( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
<> completer (tagCompleter GHC []) <> completer (tagCompleter GHC [])
<> completer (versionCompleter Nothing GHC)) <> completer (versionCompleter Nothing GHC))

View File

@@ -196,7 +196,7 @@ installOpts tool =
<> completer (toolDlCompleter (fromMaybe GHC tool)) <> completer (toolDlCompleter (fromMaybe GHC tool))
) )
) )
<*> (Just <$> toolVersionTagArgument Nothing tool) <*> (Just <$> toolVersionArgument Nothing tool)
) )
<|> pure (Nothing, Nothing) <|> pure (Nothing, Nothing)
) )

View File

@@ -84,7 +84,7 @@ prefetchP = subparser
<$> (PrefetchGHCOptions <$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) <$> ( 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/)" <> completer (bashCompleter "directory")))) <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> optional (toolVersionTagArgument Nothing (Just GHC)) ) <*> optional (toolVersionArgument Nothing (Just GHC)) )
( progDesc "Download GHC assets for installation") ( progDesc "Download GHC assets for installation")
) )
<> <>
@@ -93,7 +93,7 @@ prefetchP = subparser
(info (info
(PrefetchCabal (PrefetchCabal
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper )) <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation") ( progDesc "Download cabal assets for installation")
) )
<> <>
@@ -102,7 +102,7 @@ prefetchP = subparser
(info (info
(PrefetchHLS (PrefetchHLS
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper )) <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation") ( progDesc "Download HLS assets for installation")
) )
<> <>
@@ -111,7 +111,7 @@ prefetchP = subparser
(info (info
(PrefetchStack (PrefetchStack
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )) <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation") ( progDesc "Download stack assets for installation")
) )
<> <>

View File

@@ -103,7 +103,7 @@ rmParser =
rmOpts :: Maybe Tool -> Parser RmOptions rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool

View File

@@ -5,7 +5,6 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Run where module GHCup.OptParse.Run where
@@ -19,7 +18,6 @@ import GHCup.Prelude
import GHCup.Prelude.File import GHCup.Prelude.File
#ifdef IS_WINDOWS #ifdef IS_WINDOWS
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prelude.Process.Windows ( execNoMinGW )
#endif #endif
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
@@ -47,7 +45,6 @@ import qualified Data.Text as T
#ifndef IS_WINDOWS #ifndef IS_WINDOWS
import qualified System.Posix.Process as SPP import qualified System.Posix.Process as SPP
#endif #endif
import Data.Versions ( prettyVer, Version )
@@ -61,7 +58,6 @@ import Data.Versions ( prettyVer, Version )
data RunOptions = RunOptions data RunOptions = RunOptions
{ runAppendPATH :: Bool { runAppendPATH :: Bool
, runInstTool' :: Bool , runInstTool' :: Bool
, runMinGWPath :: Bool
, runGHCVer :: Maybe ToolVersion , runGHCVer :: Maybe ToolVersion
, runCabalVer :: Maybe ToolVersion , runCabalVer :: Maybe ToolVersion
, runHLSVer :: Maybe ToolVersion , runHLSVer :: Maybe ToolVersion
@@ -86,11 +82,9 @@ runOpts =
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)") (short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
<*> switch <*> switch
(short 'i' <> long "install" <> help "Install the tool, if missing") (short 'i' <> long "install" <> help "Install the tool, if missing")
<*> switch
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
<*> optional <*> optional
(option (option
(eitherReader ghcVersionTagEither) (eitherReader toolVersionEither)
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version" (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
<> completer (tagCompleter GHC []) <> completer (tagCompleter GHC [])
<> (completer $ versionCompleter Nothing GHC) <> (completer $ versionCompleter Nothing GHC)
@@ -98,7 +92,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionTagEither) (eitherReader toolVersionEither)
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version" (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
<> completer (tagCompleter Cabal []) <> completer (tagCompleter Cabal [])
<> (completer $ versionCompleter Nothing Cabal) <> (completer $ versionCompleter Nothing Cabal)
@@ -106,7 +100,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionTagEither) (eitherReader toolVersionEither)
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version" (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
<> completer (tagCompleter HLS []) <> completer (tagCompleter HLS [])
<> (completer $ versionCompleter Nothing HLS) <> (completer $ versionCompleter Nothing HLS)
@@ -114,7 +108,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionTagEither) (eitherReader toolVersionEither)
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version" (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
<> completer (tagCompleter Stack []) <> completer (tagCompleter Stack [])
<> (completer $ versionCompleter Nothing Stack) <> (completer $ versionCompleter Nothing Stack)
@@ -219,7 +213,7 @@ runRUN appState action' = do
run :: forall m . run :: forall m.
( MonadFail m ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
@@ -235,16 +229,12 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
r <- if not runQuick r <- if not runQuick
then runRUN runAppState $ do then runRUN runAppState $ do
toolchain <- liftE resolveToolchainFull toolchain <- liftE resolveToolchainFull
tmp <- liftIO $ createTmpDir toolchain
-- oh dear
r <- lift ask
tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain
liftE $ installToolChainFull toolchain tmp liftE $ installToolChainFull toolchain tmp
pure tmp pure tmp
else runLeanRUN leanAppstate $ do else runLeanRUN leanAppstate $ do
toolchain <- resolveToolchain toolchain <- resolveToolchain
tmp <- lift $ createTmpDir toolchain tmp <- liftIO $ createTmpDir toolchain
liftE $ installToolChain toolchain tmp liftE $ installToolChain toolchain tmp
pure tmp pure tmp
case r of case r of
@@ -259,9 +249,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ExitSuccess pure ExitSuccess
#else #else
r' <- if runMinGWPath r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
case r' of case r' of
VRight _ -> pure ExitSuccess VRight _ -> pure ExitSuccess
VLeft e -> do VLeft e -> do
@@ -274,6 +262,17 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
where where
createTmpDir :: Toolchain -> IO FilePath
createTmpDir toolchain =
case runBinDir of
Just bindir -> do
createDirRecursive' bindir
canonicalizePath bindir
Nothing -> do
d <- predictableTmpDir toolchain
createDirRecursive' d
canonicalizePath d
-- TODO: doesn't work for cross -- TODO: doesn't work for cross
resolveToolchainFull :: ( MonadFail m resolveToolchainFull :: ( MonadFail m
, MonadThrow m , MonadThrow m
@@ -291,33 +290,29 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
pure v pure v
cabalVer <- forM runCabalVer $ \ver -> do cabalVer <- forM runCabalVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Cabal (v, _) <- liftE $ fromVersion (Just ver) Cabal
pure (_tvVersion v) pure v
hlsVer <- forM runHLSVer $ \ver -> do hlsVer <- forM runHLSVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) HLS (v, _) <- liftE $ fromVersion (Just ver) HLS
pure (_tvVersion v) pure v
stackVer <- forM runStackVer $ \ver -> do stackVer <- forM runStackVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Stack (v, _) <- liftE $ fromVersion (Just ver) Stack
pure (_tvVersion v) pure v
pure Toolchain{..} pure Toolchain{..}
resolveToolchain = do resolveToolchain = do
ghcVer <- case runGHCVer of ghcVer <- case runGHCVer of
Just (GHCVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Just (ToolVersion v) -> pure $ Just (mkTVer v)
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
cabalVer <- case runCabalVer of cabalVer <- case runCabalVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
hlsVer <- case runHLSVer of hlsVer <- case runHLSVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
stackVer <- case runStackVer of stackVer <- case runStackVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
@@ -352,43 +347,35 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, MergeFileTreeError , MergeFileTreeError
] (ResourceT (ReaderT AppState m)) () ] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do installToolChainFull Toolchain{..} tmp = do
case ghcVer of forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
Just v -> do isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
isInstalled <- lift $ checkIfToolInstalled' GHC v case mt of
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin Just (GHC, v) -> do
(_tvVersion v) unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
GHCupInternal (_tvVersion v)
False GHCupInternal
[] False
setGHC' v tmp []
_ -> pure () setTool GHC v tmp
case cabalVer of Just (Cabal, v) -> do
Just v -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v) (_tvVersion v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin GHCupInternal
v False
GHCupInternal setTool Cabal v tmp
False Just (Stack, v) -> do
setCabal' v tmp unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
_ -> pure () (_tvVersion v)
case stackVer of GHCupInternal
Just v -> do False
isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v) setTool Stack v tmp
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin Just (HLS, v) -> do
v unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
GHCupInternal (_tvVersion v)
False GHCupInternal
setStack' v tmp False
_ -> pure () setTool HLS v tmp
case hlsVer of _ -> pure ()
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
v
GHCupInternal
False
setHLS' v tmp
_ -> pure ()
installToolChain :: ( MonadFail m installToolChain :: ( MonadFail m
, MonadThrow m , MonadThrow m
@@ -399,46 +386,45 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
-> FilePath -> FilePath
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) () -> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
installToolChain Toolchain{..} tmp = do installToolChain Toolchain{..} tmp = do
case ghcVer of forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
Just v -> setGHC' v tmp case mt of
_ -> pure () Just (GHC, v) -> setTool GHC v tmp
case cabalVer of Just (Cabal, v) -> setTool Cabal v tmp
Just v -> setCabal' v tmp Just (Stack, v) -> setTool Stack v tmp
_ -> pure () Just (HLS, v) -> setTool HLS v tmp
case stackVer of _ -> pure ()
Just v -> setStack' v tmp
_ -> pure ()
case hlsVer of
Just v -> setHLS' v tmp
_ -> pure ()
setGHC' v tmp = do setTool tool v tmp =
case tool of
GHC -> do
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp) void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
void $ liftE $ setGHC v SetGHCOnly (Just tmp) void $ liftE $ setGHC v SetGHCOnly (Just tmp)
setCabal' v tmp = do Cabal -> do
bin <- liftE $ whereIsTool Cabal (mkTVer v) bin <- liftE $ whereIsTool Cabal v
cbin <- liftIO $ canonicalizePath bin cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt)) lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
setStack' v tmp = do Stack -> do
bin <- liftE $ whereIsTool Stack (mkTVer v) bin <- liftE $ whereIsTool Stack v
cbin <- liftIO $ canonicalizePath bin cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt)) lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
setHLS' v tmp = do HLS -> do
Dirs {..} <- getDirs Dirs {..} <- getDirs
legacy <- isLegacyHLS v let v' = _tvVersion v
legacy <- isLegacyHLS v'
if legacy if legacy
then do then do
-- TODO: factor this out -- TODO: factor this out
hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v)) hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v' !? (NotInstalled HLS (mkTVer v'))
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper) cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw) lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>)) hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
forM_ hlsBins $ \bin -> forM_ hlsBins $ \bin ->
lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin) lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
liftE $ setHLS v SetHLSOnly (Just tmp) liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
else do else do
liftE $ setHLS v SetHLS_XYZ (Just tmp) liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)
liftE $ setHLS v SetHLSOnly (Just tmp) liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
GHCup -> pure ()
addToPath path = do addToPath path = do
cEnv <- Map.fromList <$> getEnvironment cEnv <- Map.fromList <$> getEnvironment
@@ -451,38 +437,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
liftIO $ setEnv pathVar newPath liftIO $ setEnv pathVar newPath
return envWithNewPath return envWithNewPath
createTmpDir :: ( MonadUnliftIO m predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =
, MonadCatch m liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))
, MonadThrow m
, MonadMask m
, MonadIO m
)
=> Toolchain
-> ReaderT LeanAppState m FilePath
createTmpDir toolchain =
case runBinDir of
Just bindir -> do
liftIO $ createDirRecursive' bindir
liftIO $ canonicalizePath bindir
Nothing -> do
d <- predictableTmpDir toolchain
liftIO $ createDirRecursive' d
liftIO $ canonicalizePath d
predictableTmpDir :: Monad m
=> Toolchain
-> ReaderT LeanAppState m FilePath
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do
Dirs { tmpDir } <- getDirs
pure (fromGHCupPath tmpDir </> "ghcup-none")
predictableTmpDir Toolchain{..} = do predictableTmpDir Toolchain{..} = do
Dirs { tmpDir } <- getDirs tmp <- getTemporaryDirectory
pure $ fromGHCupPath tmpDir pure $ tmp
</> ("ghcup-" <> intercalate "_" </> ("ghcup-" <> intercalate "_"
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer ( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . tVerToText) hlsVer
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer
) )
) )
@@ -496,7 +460,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
data Toolchain = Toolchain data Toolchain = Toolchain
{ ghcVer :: Maybe GHCTargetVersion { ghcVer :: Maybe GHCTargetVersion
, cabalVer :: Maybe Version , cabalVer :: Maybe GHCTargetVersion
, hlsVer :: Maybe Version , hlsVer :: Maybe GHCTargetVersion
, stackVer :: Maybe Version , stackVer :: Maybe GHCTargetVersion
} deriving Show }

View File

@@ -82,7 +82,7 @@ setParser =
"ghc" "ghc"
( SetGHC ( SetGHC
<$> info <$> info
(setOpts GHC <**> helper) (setOpts (Just GHC) <**> helper)
( progDesc "Set GHC version" ( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter) <> footerDoc (Just $ text setGHCFooter)
) )
@@ -91,7 +91,7 @@ setParser =
"cabal" "cabal"
( SetCabal ( SetCabal
<$> info <$> info
(setOpts Cabal <**> helper) (setOpts (Just Cabal) <**> helper)
( progDesc "Set Cabal version" ( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter) <> footerDoc (Just $ text setCabalFooter)
) )
@@ -100,7 +100,7 @@ setParser =
"hls" "hls"
( SetHLS ( SetHLS
<$> info <$> info
(setOpts HLS <**> helper) (setOpts (Just HLS) <**> helper)
( progDesc "Set haskell-language-server version" ( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter) <> footerDoc (Just $ text setHLSFooter)
) )
@@ -109,14 +109,14 @@ setParser =
"stack" "stack"
( SetStack ( SetStack
<$> info <$> info
(setOpts Stack <**> helper) (setOpts (Just Stack) <**> helper)
( progDesc "Set stack version" ( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter) <> footerDoc (Just $ text setStackFooter)
) )
) )
) )
) )
<|> (Right <$> setOpts GHC) <|> (Right <$> setOpts Nothing)
where where
setGHCFooter :: String setGHCFooter :: String
setGHCFooter = [s|Discussion: setGHCFooter = [s|Discussion:
@@ -137,25 +137,22 @@ setParser =
Sets the the current haskell-language-server version.|] Sets the the current haskell-language-server version.|]
setOpts :: Tool -> Parser SetOptions setOpts :: Maybe Tool -> Parser SetOptions
setOpts tool = SetOptions <$> setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$> (fromMaybe SetRecommended <$>
optional (setVersionArgument (Just ListInstalled) tool)) optional (setVersionArgument (Just ListInstalled) tool))
setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
setVersionArgument criteria tool = setVersionArgument criteria tool =
argument (eitherReader setEither) argument (eitherReader setEither)
(metavar "VERSION|TAG|next" (metavar "VERSION|TAG|next"
<> completer (tagCompleter tool ["next"]) <> completer (tagCompleter (fromMaybe GHC tool) ["next"])
<> (completer . versionCompleter criteria) tool) <> foldMap (completer . versionCompleter criteria) tool)
where where
setEither s' = setEither s' =
parseSet s' parseSet s'
<|> second SetToolTag (tagEither s') <|> second SetToolTag (tagEither s')
<|> se s' <|> second SetToolVersion (tVersionEither s')
se s' = case tool of
GHC -> second SetGHCVersion (ghcVersionEither s')
_ -> second SetToolVersion (toolVersionEither s')
parseSet s' = case fmap toLower s' of parseSet s' = case fmap toLower s' of
"next" -> Right SetNext "next" -> Right SetNext
other -> Left $ "Unknown tag/version " <> other other -> Left $ "Unknown tag/version " <> other
@@ -264,9 +261,9 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
(Right sopts) -> do (Right sopts) -> do
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
setGHC' sopts setGHC' sopts
(Left (SetGHC sopts)) -> setGHC' sopts (Left (SetGHC sopts)) -> setGHC' sopts
(Left (SetCabal sopts)) -> setCabal' sopts (Left (SetCabal sopts)) -> setCabal' sopts
(Left (SetHLS sopts)) -> setHLS' sopts (Left (SetHLS sopts)) -> setHLS' sopts
(Left (SetStack sopts)) -> setStack' sopts (Left (SetStack sopts)) -> setStack' sopts
where where
@@ -274,7 +271,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setGHC' SetOptions{ sToolVer } = setGHC' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetGHCVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v) (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)
_ -> runSetGHC runAppState (do _ -> runSetGHC runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly Nothing liftE $ setGHC v SetGHCOnly Nothing
@@ -294,17 +291,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setCabal' SetOptions{ sToolVer } = setCabal' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer v)) (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v)
_ -> runSetCabal runAppState (do _ -> runSetCabal runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v) liftE $ setCabal (_tvVersion v)
pure v pure v
) )
>>= \case >>= \case
VRight v -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version" "Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
@@ -314,17 +311,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setHLS' SetOptions{ sToolVer } = setHLS' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer v)) (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v)
_ -> runSetHLS runAppState (do _ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
pure v pure v
) )
>>= \case >>= \case
VRight v -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version" "HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
@@ -335,17 +332,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setStack' SetOptions{ sToolVer } = setStack' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer v)) (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v)
_ -> runSetStack runAppState (do _ -> runSetStack runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v) liftE $ setStack (_tvVersion v)
pure v pure v
) )
>>= \case >>= \case
VRight v -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version" "Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e

View File

@@ -82,7 +82,7 @@ whereisP = subparser
command command
"ghc" "ghc"
(WhereisTool GHC <$> info (WhereisTool GHC <$> info
( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper ) ( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
( progDesc "Get GHC location" ( progDesc "Get GHC location"
<> footerDoc (Just $ text whereisGHCFooter )) <> footerDoc (Just $ text whereisGHCFooter ))
) )
@@ -90,7 +90,7 @@ whereisP = subparser
command command
"cabal" "cabal"
(WhereisTool Cabal <$> info (WhereisTool Cabal <$> info
( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper ) ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )
( progDesc "Get cabal location" ( progDesc "Get cabal location"
<> footerDoc (Just $ text whereisCabalFooter )) <> footerDoc (Just $ text whereisCabalFooter ))
) )
@@ -98,7 +98,7 @@ whereisP = subparser
command command
"hls" "hls"
(WhereisTool HLS <$> info (WhereisTool HLS <$> info
( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper ) ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )
( progDesc "Get HLS location" ( progDesc "Get HLS location"
<> footerDoc (Just $ text whereisHLSFooter )) <> footerDoc (Just $ text whereisHLSFooter ))
) )
@@ -106,7 +106,7 @@ whereisP = subparser
command command
"stack" "stack"
(WhereisTool Stack <$> info (WhereisTool Stack <$> info
( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ) ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )
( progDesc "Get stack location" ( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter )) <> footerDoc (Just $ text whereisStackFooter ))
) )
@@ -268,23 +268,9 @@ whereis :: ( Monad m
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
Dirs{ .. } <- runReaderT getDirs leanAppstate Dirs{ .. } <- runReaderT getDirs leanAppstate
case (whereisCommand, whereisOptions) of case (whereisCommand, whereisOptions) of
(WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) -> (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool (mkTVer v) loc <- liftE $ whereIsTool tool v
if directory if directory
then pure $ takeDirectory loc then pure $ takeDirectory loc
else pure loc else pure loc

View File

@@ -26,6 +26,7 @@ import GHCup.Prelude
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
import GHCup.Version import GHCup.Version
import GHC.Debug.Stub
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
import Control.Concurrent import Control.Concurrent
@@ -120,7 +121,7 @@ plan_json = $( do
main :: IO () main :: IO ()
main = do main = withGhcDebug $ do
-- https://gitlab.haskell.org/ghc/ghc/issues/8118 -- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8 setLocaleEncoding utf8
@@ -337,14 +338,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
(GHC, ver) = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
(GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion over) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Upgrade {}) (GHCup, _) = pure True alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
alreadyInstalling _ _ = pure False alreadyInstalling _ _ = pure False
cmp' :: ( HasLog env cmp' :: ( HasLog env

View File

@@ -32,4 +32,7 @@ package aeson
package streamly package streamly
flags: +use-unliftio flags: +use-unliftio
package *
ghc-options: -finfo-table-map -fdistinct-constructor-tables
allow-newer: base, ghc-prim, template-haskell, language-c allow-newer: base, ghc-prim, template-haskell, language-c

View File

@@ -74,15 +74,12 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
## Known users ## Known users
* CI: * Github actions:
- [Github actions/virtual-environments](https://github.com/actions/virtual-environments) - [actions/virtual-environments](https://github.com/actions/virtual-environments)
- [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup) - [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
* mirrors: * mirrors:
- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup) - [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
* tools: * tools:
- [vscode-haskell](https://github.com/haskell/vscode-haskell)
- [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
- [vabal](https://github.com/Franciman/vabal) - [vabal](https://github.com/Franciman/vabal)
## Known problems ## Known problems

View File

@@ -324,34 +324,3 @@ ghcup run --ghc 8.10.7 --cabal latest --hls latest --stack latest --install -- c
``` ```
This will execute vscode with GHC set to 8.10.7 and all other tools to their latest version. This will execute vscode with GHC set to 8.10.7 and all other tools to their latest version.
# Troubleshooting
## Script immediately exits on windows
There are two possible reasons:
1. your company blocks the script (some have a whitelist)... ask your administrator
2. your Antivirus or Windows Defender interfere with the installation. Disable them temporarily.
## C compiler cannot create executables
### Darwin
You need to update your XCode command line tools, e.g. [like this](https://stackoverflow.com/questions/34617452/how-to-update-xcode-from-command-line).
## Certificate authority errors (curl)
If your certificates are outdated or improperly configured, curl may be unable
to download ghcup.
There are two known workarounds:
1. Tell curl to ignore certificate errors (dangerous): `curl -k https://gitlab.haskell.org/haskell/ghcup-hs/-/raw/master/scripts/bootstrap/bootstrap-haskell | GHCUP_CURL_OPTS="-k" sh`
2. Try to use wget instead: `wget -O /dev/stdout https://gitlab.haskell.org/haskell/ghcup-hs/-/raw/master/scripts/bootstrap/bootstrap-haskell | BOOTSTRAP_HASKELL_DOWNLOADER=wget sh`
On windows, you can disable curl like so:
```pwsh
Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true,$false,$false,$false,$false,$false,$false,"","","","",$true
```

View File

@@ -57,7 +57,7 @@ hide:
</section> </section>
<p id="help" class="ghcup-help"> <p id="help" class="ghcup-help">
Need help? Check the <a href="guide/#troubleshooting">Troubleshooting section</a> or ask on Need help? Ask on
<span> <span>
<a href="https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup"> <a href="https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup">
<img src="irc.svg" alt="" /> <img src="irc.svg" alt="" />

View File

@@ -200,14 +200,6 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See [ghcup.vim](https://github.com/hasufell/ghcup.vim). See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## VSCode integration
The developers of the Haskell Language Server offer an [extension](https://github.com/haskell/vscode-haskell) tightly integrated with the [Haskell Language Server](https://github.com/haskell/haskell-language-server). To get started:
1. Install GHCup. During installation, opt in to install the Haskell Language Server (HLS).
2. Install the extension (from VSCode: Ctrl + P and then `ext install haskell.haskell`).
3. Make sure your project uses the GHC version installed from GHCup (otherwise HLS is likely to fail on launch):
- instructions for [stack](https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc)
## Get help ## Get help
* [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup) * [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)

View File

@@ -109,7 +109,7 @@ library
, base16-bytestring >=0.1.1.6 && <1.1 , base16-bytestring >=0.1.1.6 && <1.1
, binary ^>=0.8.6.0 , binary ^>=0.8.6.0
, bytestring >=0.10 && <0.12 , bytestring >=0.10 && <0.12
, Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 , Cabal ^>=3.6.2.0
, case-insensitive ^>=1.2.1.0 , case-insensitive ^>=1.2.1.0
, casing ^>=0.1.4.1 , casing ^>=0.1.4.1
, containers ^>=0.6 , containers ^>=0.6
@@ -164,10 +164,8 @@ library
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
other-modules: other-modules:
GHCup.Prelude.File.Windows GHCup.Prelude.File.Windows
GHCup.Prelude.Windows
-- GHCup.OptParse.Run uses this
exposed-modules:
GHCup.Prelude.Process.Windows GHCup.Prelude.Process.Windows
GHCup.Prelude.Windows
build-depends: build-depends:
, bzlib , bzlib
@@ -242,6 +240,7 @@ executable ghcup
, deepseq ^>=1.4 , deepseq ^>=1.4
, directory ^>=1.3.6.0 , directory ^>=1.3.6.0
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, ghc-debug-stub
, ghcup , ghcup
, haskus-utils-types ^>=1.5 , haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1

View File

@@ -137,7 +137,7 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
instance Pretty AlreadyInstalled where instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') = pPrint (AlreadyInstalled tool ver') =
(pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;" pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed;"
<+> text "if you really want to reinstall it, you may want to run 'ghcup install cabal --force" <+> (pPrint ver' <> text "'") <+> text "if you really want to reinstall it, you may want to run 'ghcup install cabal --force" <+> (pPrint ver' <> text "'")

View File

@@ -566,11 +566,8 @@ rmGHCVer ver = do
lift $ recycleFile f lift $ recycleFile f
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
Nothing -> do Nothing -> do
isDir <- liftIO $ doesDirectoryExist dir lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink dir lift $ recyclePathForcibly dir'
when (isDir && not isSyml) $ do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
recyclePathForcibly dir'
v' <- v' <-
handle handle
@@ -684,53 +681,28 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, "origin" , "origin"
, fromString rep ] , fromString rep ]
-- figure out if we can do a shallow clone let fetch_args =
remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure []) [ "fetch"
$ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack) , "--depth"
let shallow_clone , "1"
| isCommitHash ref = True , "--quiet"
| fromString ref `elem` remoteBranches = True , "origin"
| otherwise = False , fromString ref ]
lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)
-- fetch
let fetch_args
| shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]
| otherwise = ["fetch", "--tags", "--quiet", "origin" ]
lEM $ git fetch_args lEM $ git fetch_args
-- initial checkout lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "checkout", fromString ref ]
-- gather some info
git_describe <- if shallow_clone
then pure Nothing
else fmap Just $ liftE $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
chash <- liftE $ gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
-- clone submodules
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
-- apply patches
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
-- bootstrap
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
tver <- case _exitCode of case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
"GHC version (from Makefile): " <> prettyVer tver <>
(if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
(if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
pure tver
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
-- the version that's installed may differ from the -- the version that's installed may differ from the

View File

@@ -327,7 +327,7 @@ compileHLS :: ( MonadMask m
=> Either Version GitBranch => Either Version GitBranch
-> [Version] -> [Version]
-> Maybe Int -> Maybe Int
-> Either Bool Version -> Maybe Version
-> InstallDir -> InstallDir
-> Maybe (Either FilePath URI) -> Maybe (Either FilePath URI)
-> Maybe URI -> Maybe URI
@@ -349,7 +349,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
(workdir, tver, git_describe) <- case targetHLS of (workdir, tver) <- case targetHLS of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer tver lift $ logDebug $ "Requested to compile: " <> prettyVer tver
@@ -369,13 +369,13 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
(liftE . intoSubdir tmpUnpack) (liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo) (view dlSubdir dlInfo)
pure (workdir, tver, Nothing) pure (workdir, tver)
-- clone from git -- clone from git
Right GitBranch{..} -> do Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
reThrowAll @_ @'[ProcessError] DownloadFailed $ do tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ] lEM $ git [ "init" ]
@@ -384,61 +384,33 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
, "origin" , "origin"
, fromString rep ] , fromString rep ]
-- figure out if we can do a shallow clone let fetch_args =
remoteBranches <- catchE @ProcessError @'[ProcessError] @'[] (\_ -> pure []) [ "fetch"
$ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack) , "--depth"
let shallow_clone , "1"
| gitDescribeRequested = False , "--quiet"
| isCommitHash ref = True , "origin"
| fromString ref `elem` remoteBranches = True , fromString ref ]
| otherwise = False
lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)
-- fetch
let fetch_args
| shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]
| otherwise = ["fetch", "--tags", "--quiet", "origin" ]
lEM $ git fetch_args lEM $ git fetch_args
-- checkout lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "checkout", fromString ref ] (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
pure . (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
-- gather some info liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
git_describe <- if shallow_clone lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
then pure Nothing
else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
(Just gpd) <- parseGenericPackageDescriptionMaybe
<$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
let tver = (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) pure (tmpUnpack, tver)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>
"HLS version (from cabal file): " <> prettyVer tver <>
(if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
(if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)
pure (tmpUnpack, tver, git_describe)
-- the version that's installed may differ from the -- the version that's installed may differ from the
-- compiled version, so the user can overwrite it -- compiled version, so the user can overwrite it
installVer <- case ov of let installVer = fromMaybe tver ov
Left True -> case git_describe of
-- git describe
Just h -> either (fail . displayException) pure . version $ h
-- git describe, but not building from git, lol
Nothing -> pure tver
-- default: use detected version
Left False -> pure tver
-- overwrite version with users value
Right v -> pure v
liftE $ runBuildAction liftE $ runBuildAction
workdir workdir
@@ -492,7 +464,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
pure ghcInstallDir pure ghcInstallDir
forM_ artifacts $ \artifact -> do forM_ artifacts $ \artifact -> do
logDebug $ T.pack (show artifact) logInfo $ T.pack (show artifact)
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt) liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt) (tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt) liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
@@ -507,10 +479,6 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
) )
pure installVer pure installVer
where
gitDescribeRequested = case ov of
Left b -> b
_ -> False
----------------- -----------------
@@ -646,11 +614,8 @@ rmHLSVer ver = do
lift $ recycleFile f lift $ recycleFile f
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
Nothing -> do Nothing -> do
isDir <- liftIO $ doesDirectoryExist hlsDir lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink hlsDir recyclePathForcibly hlsDir'
when (isDir && not isSyml) $ do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
recyclePathForcibly hlsDir'
when (Just ver == isHlsSet) $ do when (Just ver == isHlsSet) $ do
-- set latest hls -- set latest hls

View File

@@ -206,36 +206,10 @@ exec :: MonadIO m
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
exec exe args chdir env = do exec exe args chdir env = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
forM_ (Map.fromList <$> env) $ \cEnv -> do
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
liftIO $ setEnv "PATH" ""
liftIO $ setEnv "Path" newPath
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code pure $ toProcessError exe args exit_code
-- | Like 'exec', except doesn't add msys2 stuff to PATH.
execNoMinGW :: MonadIO m
=> FilePath -- ^ thing to execute
-> [FilePath] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execNoMinGW exe args chdir env = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
forM_ (Map.fromList <$> env) $ \cEnv -> do
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
liftIO $ setEnv "PATH" ""
liftIO $ setEnv "Path" newPath
let cp = (proc exe args) { cwd = chdir, env = env }
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code
-- | Thin wrapper around `executeFile`. -- | Thin wrapper around `executeFile`.
execShell :: MonadIO m execShell :: MonadIO m

View File

@@ -407,9 +407,6 @@ data AppState = AppState
instance NFData AppState instance NFData AppState
fromAppState :: AppState -> LeanAppState
fromAppState AppState {..} = LeanAppState {..}
data LeanAppState = LeanAppState data LeanAppState = LeanAppState
{ settings :: Settings { settings :: Settings
, dirs :: Dirs , dirs :: Dirs

View File

@@ -61,7 +61,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit )
import Data.Bifunctor ( first ) import Data.Bifunctor ( first )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
@@ -1276,35 +1275,3 @@ warnAboutHlsCompatibility = do
T.pack (prettyShow supportedGHC) T.pack (prettyShow supportedGHC)
_ -> return () _ -> return ()
-----------
--[ Git ]--
-----------
isCommitHash :: String -> Bool
isCommitHash str' = let hex = all isHexDigit str'
len = length str'
in hex && len == 40
gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
gitOut args dir = do
CapturedProcess {..} <- lift $ executeOut "git" args (Just dir)
case _exitCode of
ExitSuccess -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
ExitFailure c -> do
let pe = NonZeroExit c "git" args
lift $ logDebug $ T.pack (prettyShow pe)
throwE pe
processBranches :: T.Text -> [String]
processBranches str' = let lines' = lines (T.unpack str')
words' = fmap words lines'
refs = catMaybes $ fmap (`atMay` 1) words'
branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
in branches

View File

@@ -16,7 +16,6 @@
# * BOOTSTRAP_HASKELL_INSTALL_HLS - whether to install latest hls # * BOOTSTRAP_HASKELL_INSTALL_HLS - whether to install latest hls
# * BOOTSTRAP_HASKELL_ADJUST_BASHRC - whether to adjust PATH in bashrc (prepend) # * BOOTSTRAP_HASKELL_ADJUST_BASHRC - whether to adjust PATH in bashrc (prepend)
# * BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG - whether to adjust mingw paths in cabal.config on windows # * BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG - whether to adjust mingw paths in cabal.config on windows
# * BOOTSTRAP_HASKELL_DOWNLOADER - which downloader to use (default: curl)
# * GHCUP_BASE_URL - the base url for ghcup binary download (use this to overwrite https://downloads.haskell.org/~ghcup with a mirror) # * GHCUP_BASE_URL - the base url for ghcup binary download (use this to overwrite https://downloads.haskell.org/~ghcup with a mirror)
# License: LGPL-3.0 # License: LGPL-3.0
@@ -31,7 +30,6 @@ ghver="0.1.17.8"
: "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}" : "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}"
export GHCUP_SKIP_UPDATE_CHECK=yes export GHCUP_SKIP_UPDATE_CHECK=yes
: "${BOOTSTRAP_HASKELL_DOWNLOADER:=curl}"
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*)
@@ -135,15 +133,6 @@ _eghcup() {
fi fi
} }
ecabal() {
edo _ecabal "$@"
}
_ecabal() {
# shellcheck disable=SC2086
"${GHCUP_BIN}/cabal" "$@"
}
_done() { _done() {
echo echo
echo "===============================================================================" echo "==============================================================================="
@@ -324,35 +313,11 @@ download_ghcup() {
esac esac
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*)
case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup.exe
"curl")
# shellcheck disable=SC2086
edo curl -Lf ${GHCUP_CURL_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup.exe
;;
"wget")
# shellcheck disable=SC2086
edo wget -O /dev/stdout ${GHCUP_WGET_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup.exe
;;
*)
die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"
;;
esac
edo chmod +x "${GHCUP_BIN}"/ghcup.exe edo chmod +x "${GHCUP_BIN}"/ghcup.exe
;; ;;
*) *)
case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
"curl")
# shellcheck disable=SC2086
edo curl -Lf ${GHCUP_CURL_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup
;;
"wget")
# shellcheck disable=SC2086
edo wget -O /dev/stdout ${GHCUP_WGET_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup
;;
*)
die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"
;;
esac
edo chmod +x "${GHCUP_BIN}"/ghcup edo chmod +x "${GHCUP_BIN}"/ghcup
;; ;;
esac esac
@@ -379,17 +344,6 @@ download_ghcup() {
# shellcheck disable=SC1090 # shellcheck disable=SC1090
edo . "${GHCUP_DIR}"/env edo . "${GHCUP_DIR}"/env
case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in
"curl")
eghcup config set downloader Curl
;;
"wget")
eghcup config set downloader Wget
;;
*)
die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"
;;
esac
eghcup upgrade eghcup upgrade
} }
@@ -583,7 +537,7 @@ adjust_cabal_config() {
else else
cabal_bin="$HOME/AppData/Roaming/cabal/bin" cabal_bin="$HOME/AppData/Roaming/cabal/bin"
fi fi
ecabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
} }
ask_cabal_config_init() { ask_cabal_config_init() {
@@ -734,7 +688,7 @@ find_shell
echo echo
echo "Welcome to Haskell!" echo "Welcome to Haskell!"
echo echo
echo "This script can download and install the following binaries:" echo "This script will download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer" echo " * ghcup - The Haskell toolchain installer"
echo " * ghc - The Glasgow Haskell Compiler" echo " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool for managing Haskell software" echo " * cabal - The Cabal build tool for managing Haskell software"

View File

@@ -36,9 +36,7 @@ param (
# Instead of installing a new MSys2, use an existing installation # Instead of installing a new MSys2, use an existing installation
[string]$ExistingMsys2Dir, [string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal') # Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir, [string]$CabalDir
# Whether to disable use of curl.exe
[switch]$DisableCurl
) )
$Silent = !$Interactive $Silent = !$Interactive
@@ -244,7 +242,7 @@ if ($Silent -and !($InstallDir)) {
Print-Msg -color Magenta -msg (@' Print-Msg -color Magenta -msg (@'
Welcome to Haskell! Welcome to Haskell!
This script can download and install the following programs: This script will download and install the following programs:
* ghcup - The Haskell toolchain installer * ghcup - The Haskell toolchain installer
* ghc - The Glasgow Haskell Compiler * ghc - The Glasgow Haskell Compiler
* msys2 - A linux-style toolchain environment required for many operations * msys2 - A linux-style toolchain environment required for many operations
@@ -427,7 +425,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
$archive = 'msys2-x86_64-latest.sfx.exe' $archive = 'msys2-x86_64-latest.sfx.exe'
$archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive") $archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive")
if ((Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) -and !($DisableCurl)) { if (Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) {
Exec "curl.exe" '-o' "$archivePath" ('https://repo.msys2.org/distrib/{0}' -f "$archive") Exec "curl.exe" '-o' "$archivePath" ('https://repo.msys2.org/distrib/{0}' -f "$archive")
} else { } else {
Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder ([IO.Path]::GetTempPath()) -includeStats Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder ([IO.Path]::GetTempPath()) -includeStats
@@ -593,17 +591,10 @@ if ($Minimal) {
$MinimalExport = 'export BOOTSTRAP_HASKELL_MINIMAL=1 ;' $MinimalExport = 'export BOOTSTRAP_HASKELL_MINIMAL=1 ;'
} }
if ($DisableCurl) {
$BootstrapDownloader = 'export BOOTSTRAP_HASKELL_DOWNLOADER=wget ;'
$DownloadScript = 'wget -O /dev/stdout'
} else {
$DownloadScript = 'curl --proto ''=https'' --tlsv1.2 -sSf'
}
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) { if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript) Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
} else { } else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript) Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
} }