hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix parsing issues with 'ghcup run' and non-PVP versions

Browse Source 
This is a major refactor of some CLI code. We try to distinguish
GHC versions from other versions, so that we can use distinct parsers.

Hopefully this doesn't introduce new bugs.

This also forces ghcup run to use the new internal ~/.ghcup/tmp dir.
This commit is contained in:
Julian Ospald 2022-07-11 16:05:39 +02:00
parent ce239ab88e
commit 7a2a5074fa
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
10 changed files with 197 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
app/ghcup/GHCup/OptParse/ChangeLog.hs
View File

@ -80,7 +80,7 @@ changelogP =
<> completer toolCompleter <> completer toolCompleter
) )
) )
<*> optional (toolVersionArgument Nothing Nothing) <*> optional (toolVersionTagArgument Nothing Nothing)
@ -117,7 +117,8 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
ver' = maybe ver' = maybe
(Right Latest) (Right Latest)
(\case (\case
ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion GHCVersion tv -> Left (_tvVersion tv)
ToolVersion tv -> Left tv
ToolTag t -> Right t ToolTag t -> Right t
) )
clToolVer clToolVer

64
app/ghcup/GHCup/OptParse/Common.hs
View File

@ -70,20 +70,24 @@ import Control.Exception (evaluate)
--[ Types ]-- --[ Types ]--
------------- -------------
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal data ToolVersion = GHCVersion GHCTargetVersion
| ToolVersion Version
| ToolTag Tag | ToolTag Tag
-- a superset of ToolVersion -- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion data SetToolVersion = SetGHCVersion GHCTargetVersion
| SetToolVersion Version
| SetToolTag Tag | SetToolTag Tag
| SetRecommended | SetRecommended
| SetNext | SetNext
prettyToolVer :: ToolVersion -> String prettyToolVer :: ToolVersion -> String
prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v' prettyToolVer (GHCVersion 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
@ -96,10 +100,9 @@ toSetToolVer Nothing = SetRecommended
-------------- --------------
-- | same as toolVersionParser, except as an argument. toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion toolVersionTagArgument criteria tool =
toolVersionArgument criteria tool = argument (eitherReader (parser 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)
@ -108,20 +111,19 @@ toolVersionArgument 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)
versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
-- https://github.com/pcapriotti/optparse-applicative/issues/148 -- https://github.com/pcapriotti/optparse-applicative/issues/148
@ -230,9 +232,15 @@ 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."
toolVersionEither :: String -> Either String ToolVersion -- this accepts cross prefix
toolVersionEither s' = ghcVersionTagEither :: String -> Either String ToolVersion
second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s') ghcVersionTagEither 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
@ -244,10 +252,14 @@ tagEither s' = case fmap toLower s' of
other -> Left $ "Unknown tag " <> other other -> Left $ "Unknown tag " <> other
tVersionEither :: String -> Either String GHCTargetVersion ghcVersionEither :: String -> Either String GHCTargetVersion
tVersionEither = ghcVersionEither =
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
@ -663,7 +675,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' (SetToolVersion v) tool = do fromVersion' (SetGHCVersion 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
@ -675,6 +687,18 @@ fromVersion' (SetToolVersion 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

2
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -362,7 +362,7 @@ hlsCompileOpts =
) )
) )
<*> some ( <*> some (
option (eitherReader toolVersionEither) option (eitherReader ghcVersionTagEither)
( 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))

2
app/ghcup/GHCup/OptParse/Install.hs
View File

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

8
app/ghcup/GHCup/OptParse/Prefetch.hs
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 (toolVersionArgument Nothing (Just GHC)) ) <*> optional (toolVersionTagArgument 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 (toolVersionArgument Nothing (Just Cabal)) <**> helper )) <*> ( optional (toolVersionTagArgument 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 (toolVersionArgument Nothing (Just HLS)) <**> helper )) <*> ( optional (toolVersionTagArgument 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 (toolVersionArgument Nothing (Just Stack)) <**> helper )) <*> ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation") ( progDesc "Download stack assets for installation")
) )
<> <>

2
app/ghcup/GHCup/OptParse/Rm.hs
View File

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

148
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -47,6 +47,7 @@ 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 )
@ -89,7 +90,7 @@ runOpts =
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)") (short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
<*> optional <*> optional
(option (option
(eitherReader toolVersionEither) (eitherReader ghcVersionTagEither)
(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)
@ -97,7 +98,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionEither) (eitherReader toolVersionTagEither)
(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)
@ -105,7 +106,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionEither) (eitherReader toolVersionTagEither)
(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)
@ -113,7 +114,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionEither) (eitherReader toolVersionTagEither)
(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)
@ -218,7 +219,7 @@ runRUN appState action' = do
run :: forall m. run :: forall m .
( MonadFail m ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
@ -290,29 +291,33 @@ 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 v pure (_tvVersion v)
hlsVer <- forM runHLSVer $ \ver -> do hlsVer <- forM runHLSVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) HLS (v, _) <- liftE $ fromVersion (Just ver) HLS
pure v pure (_tvVersion v)
stackVer <- forM runStackVer $ \ver -> do stackVer <- forM runStackVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Stack (v, _) <- liftE $ fromVersion (Just ver) Stack
pure v pure (_tvVersion v)
pure Toolchain{..} pure Toolchain{..}
resolveToolchain = do resolveToolchain = do
ghcVer <- case runGHCVer of ghcVer <- case runGHCVer of
Just (ToolVersion v) -> pure $ Just v Just (GHCVersion 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"
@ -347,35 +352,43 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, MergeFileTreeError , MergeFileTreeError
] (ResourceT (ReaderT AppState m)) () ] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do installToolChainFull Toolchain{..} tmp = do
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do case ghcVer of
isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt Just v -> do
case mt of isInstalled <- lift $ checkIfToolInstalled' GHC v
Just (GHC, v) -> do unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin (_tvVersion v)
(_tvVersion v) GHCupInternal
GHCupInternal False
False []
[] setGHC' v tmp
setTool GHC v tmp _ -> pure ()
Just (Cabal, v) -> do case cabalVer of
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin Just v -> do
(_tvVersion v) isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)
GHCupInternal unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
False v
setTool Cabal v tmp GHCupInternal
Just (Stack, v) -> do False
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin setCabal' v tmp
(_tvVersion v) _ -> pure ()
GHCupInternal case stackVer of
False Just v -> do
setTool Stack v tmp isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)
Just (HLS, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin v
(_tvVersion v) GHCupInternal
GHCupInternal False
False setStack' v tmp
setTool HLS v tmp _ -> pure ()
_ -> pure () case hlsVer of
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
@ -386,45 +399,46 @@ 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
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do case ghcVer of
case mt of Just v -> setGHC' v tmp
Just (GHC, v) -> setTool GHC v tmp _ -> pure ()
Just (Cabal, v) -> setTool Cabal v tmp case cabalVer of
Just (Stack, v) -> setTool Stack v tmp Just v -> setCabal' v tmp
Just (HLS, v) -> setTool HLS v tmp _ -> pure ()
_ -> pure () case stackVer of
Just v -> setStack' v tmp
_ -> pure ()
case hlsVer of
Just v -> setHLS' v tmp
_ -> pure ()
setTool tool v tmp = setGHC' v tmp = do
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)
Cabal -> do setCabal' v tmp = do
bin <- liftE $ whereIsTool Cabal v bin <- liftE $ whereIsTool Cabal (mkTVer 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))
Stack -> do setStack' v tmp = do
bin <- liftE $ whereIsTool Stack v bin <- liftE $ whereIsTool Stack (mkTVer 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))
HLS -> do setHLS' v tmp = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
let v' = _tvVersion v legacy <- isLegacyHLS 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 (_tvVersion v) SetHLSOnly (Just tmp) liftE $ setHLS v SetHLSOnly (Just tmp)
else do else do
liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp) liftE $ setHLS v SetHLS_XYZ (Just tmp)
liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp) liftE $ setHLS v SetHLSOnly (Just tmp)
GHCup -> pure ()
addToPath path = do addToPath path = do
cEnv <- Map.fromList <$> getEnvironment cEnv <- Map.fromList <$> getEnvironment
@ -466,9 +480,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
pure $ fromGHCupPath tmpDir pure $ fromGHCupPath tmpDir
</> ("ghcup-" <> intercalate "_" </> ("ghcup-" <> intercalate "_"
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer ( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . tVerToText) hlsVer <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer
) )
) )
@ -482,7 +496,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
data Toolchain = Toolchain data Toolchain = Toolchain
{ ghcVer :: Maybe GHCTargetVersion { ghcVer :: Maybe GHCTargetVersion
, cabalVer :: Maybe GHCTargetVersion , cabalVer :: Maybe Version
, hlsVer :: Maybe GHCTargetVersion , hlsVer :: Maybe Version
, stackVer :: Maybe GHCTargetVersion , stackVer :: Maybe Version
} deriving Show } deriving Show

47
app/ghcup/GHCup/OptParse/Set.hs
View File

@ -82,7 +82,7 @@ setParser =
"ghc" "ghc"
( SetGHC ( SetGHC
<$> info <$> info
(setOpts (Just GHC) <**> helper) (setOpts 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 (Just Cabal) <**> helper) (setOpts 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 (Just HLS) <**> helper) (setOpts 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 (Just Stack) <**> helper) (setOpts Stack <**> helper)
( progDesc "Set stack version" ( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter) <> footerDoc (Just $ text setStackFooter)
) )
) )
) )
) )
<|> (Right <$> setOpts Nothing) <|> (Right <$> setOpts GHC)
where where
setGHCFooter :: String setGHCFooter :: String
setGHCFooter = [s|Discussion: setGHCFooter = [s|Discussion:
@ -137,22 +137,25 @@ setParser =
Sets the the current haskell-language-server version.|] Sets the the current haskell-language-server version.|]
setOpts :: Maybe Tool -> Parser SetOptions setOpts :: 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 -> Maybe Tool -> Parser SetToolVersion setVersionArgument :: Maybe ListCriteria -> 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 (fromMaybe GHC tool) ["next"]) <> completer (tagCompleter tool ["next"])
<> foldMap (completer . versionCompleter criteria) tool) <> (completer . versionCompleter criteria) tool)
where where
setEither s' = setEither s' =
parseSet s' parseSet s'
<|> second SetToolTag (tagEither s') <|> second SetToolTag (tagEither s')
<|> second SetToolVersion (tVersionEither s') <|> se 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
@ -261,9 +264,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
@ -271,7 +274,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
(SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v) (SetGHCVersion 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
@ -291,17 +294,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 (_tvVersion v) >> pure v) (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer 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 GHCTargetVersion{..} -> do VRight v -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version" "Cabal " <> prettyVer (_tvVersion v) <> " 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
@ -311,17 +314,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 (_tvVersion v) SetHLSOnly Nothing >> pure v) (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer 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 GHCTargetVersion{..} -> do VRight v -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"HLS " <> prettyVer _tvVersion <> " successfully set as default version" "HLS " <> prettyVer (_tvVersion v) <> " 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
@ -332,17 +335,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 (_tvVersion v) >> pure v) (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer 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 GHCTargetVersion{..} -> do VRight v -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"Stack " <> prettyVer _tvVersion <> " successfully set as default version" "Stack " <> prettyVer (_tvVersion v) <> " 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

24
app/ghcup/GHCup/OptParse/Whereis.hs
View File

@ -82,7 +82,7 @@ whereisP = subparser
command command
"ghc" "ghc"
(WhereisTool GHC <$> info (WhereisTool GHC <$> info
( optional (toolVersionArgument Nothing (Just GHC)) <**> helper ) ( optional (toolVersionTagArgument 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 (toolVersionArgument Nothing (Just Cabal)) <**> helper ) ( optional (toolVersionTagArgument 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 (toolVersionArgument Nothing (Just HLS)) <**> helper ) ( optional (toolVersionTagArgument 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 (toolVersionArgument Nothing (Just Stack)) <**> helper ) ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )
( progDesc "Get stack location" ( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter )) <> footerDoc (Just $ text whereisStackFooter ))
) )
@ -268,7 +268,7 @@ 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 (ToolVersion v)), WhereisOptions{..}) -> (WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool v loc <- liftE $ whereIsTool tool v
if directory if directory
@ -282,6 +282,20 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30 pure $ ExitFailure 30
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool (mkTVer 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 whereVer, WhereisOptions{..}) -> do (WhereisTool tool whereVer, WhereisOptions{..}) -> do
runWhereIs runAppState (do runWhereIs runAppState (do

10
app/ghcup/Main.hs
View File

@ -337,14 +337,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 $ ToolVersion (mkTVer over)) ver (GHC, ver) = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
(GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion over) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver
alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True alreadyInstalling (Upgrade {}) (GHCup, _) = pure True
alreadyInstalling _ _ = pure False alreadyInstalling _ _ = pure False
cmp' :: ( HasLog env cmp' :: ( HasLog env