From 7a2a5074fab9648320b010b613bd3bdcfc612fc8 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 11 Jul 2022 16:05:39 +0200 Subject: [PATCH] Fix parsing issues with 'ghcup run' and non-PVP versions 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. --- app/ghcup/GHCup/OptParse/ChangeLog.hs | 7 +- app/ghcup/GHCup/OptParse/Common.hs | 64 +++++++---- app/ghcup/GHCup/OptParse/Compile.hs | 2 +- app/ghcup/GHCup/OptParse/Install.hs | 2 +- app/ghcup/GHCup/OptParse/Prefetch.hs | 18 ++-- app/ghcup/GHCup/OptParse/Rm.hs | 4 +- app/ghcup/GHCup/OptParse/Run.hs | 150 ++++++++++++++------------ app/ghcup/GHCup/OptParse/Set.hs | 49 +++++---- app/ghcup/GHCup/OptParse/Whereis.hs | 28 +++-- app/ghcup/Main.hs | 14 +-- 10 files changed, 197 insertions(+), 141 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs index 09af975..12a7e64 100644 --- a/app/ghcup/GHCup/OptParse/ChangeLog.hs +++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs @@ -58,7 +58,7 @@ data ChangeLogOptions = ChangeLogOptions --[ Parsers ]-- --------------- - + changelogP :: Parser ChangeLogOptions changelogP = (\x y -> ChangeLogOptions x y) @@ -80,7 +80,7 @@ changelogP = <> completer toolCompleter ) ) - <*> optional (toolVersionArgument Nothing Nothing) + <*> optional (toolVersionTagArgument Nothing Nothing) @@ -117,7 +117,8 @@ changelog ChangeLogOptions{..} runAppState runLogger = do ver' = maybe (Right Latest) (\case - ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion + GHCVersion tv -> Left (_tvVersion tv) + ToolVersion tv -> Left tv ToolTag t -> Right t ) clToolVer diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index dba8664..af227f0 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -70,20 +70,24 @@ import Control.Exception (evaluate) --[ Types ]-- ------------- -data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal +data ToolVersion = GHCVersion GHCTargetVersion + | ToolVersion Version | ToolTag Tag -- a superset of ToolVersion -data SetToolVersion = SetToolVersion GHCTargetVersion +data SetToolVersion = SetGHCVersion GHCTargetVersion + | SetToolVersion Version | SetToolTag Tag | SetRecommended | SetNext 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 toSetToolVer :: Maybe ToolVersion -> SetToolVersion +toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' toSetToolVer (Just (ToolTag t')) = SetToolTag t' toSetToolVer Nothing = SetRecommended @@ -96,10 +100,9 @@ toSetToolVer Nothing = SetRecommended -------------- --- | same as toolVersionParser, except as an argument. -toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion -toolVersionArgument criteria tool = - argument (eitherReader toolVersionEither) +toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion +toolVersionTagArgument criteria tool = + argument (eitherReader (parser tool)) (metavar (mv tool) <> completer (tagCompleter (fromMaybe GHC tool) []) <> foldMap (completer . versionCompleter criteria) tool) @@ -108,20 +111,19 @@ toolVersionArgument criteria tool = mv (Just HLS) = "HLS_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' criteria tool = argument (eitherReader (first show . version . T.pack)) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) -versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion -versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) +ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion +ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither) + (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) -- https://github.com/pcapriotti/optparse-applicative/issues/148 @@ -230,9 +232,15 @@ isolateParser f = case isValid f && isAbsolute f of True -> Right $ normalise f False -> Left "Please enter a valid filepath for isolate dir." -toolVersionEither :: String -> Either String ToolVersion -toolVersionEither s' = - second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s') +-- this accepts cross prefix +ghcVersionTagEither :: String -> Either String ToolVersion +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 s' = case fmap toLower s' of @@ -244,10 +252,14 @@ tagEither s' = case fmap toLower s' of other -> Left $ "Unknown tag " <> other -tVersionEither :: String -> Either String GHCTargetVersion -tVersionEither = +ghcVersionEither :: String -> Either String GHCTargetVersion +ghcVersionEither = 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 s' | t == T.pack "ghc" = Right GHC @@ -663,7 +675,7 @@ fromVersion' SetRecommended tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool -fromVersion' (SetToolVersion v) tool = do +fromVersion' (SetGHCVersion v) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion v) tool dls 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') pure (GHCTargetVersion (_tvTarget v) v', Just 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 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 42b6317..723dd37 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -362,7 +362,7 @@ hlsCompileOpts = ) ) <*> 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)" <> completer (tagCompleter GHC []) <> completer (versionCompleter Nothing GHC)) diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 7c99d82..ec3e408 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -196,7 +196,7 @@ installOpts tool = <> completer (toolDlCompleter (fromMaybe GHC tool)) ) ) - <*> (Just <$> toolVersionArgument Nothing tool) + <*> (Just <$> toolVersionTagArgument Nothing tool) ) <|> pure (Nothing, Nothing) ) diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 221ecef..bfb284d 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -74,44 +74,44 @@ data PrefetchGHCOptions = PrefetchGHCOptions { --[ Parsers ]-- --------------- - + prefetchP :: Parser PrefetchCommand prefetchP = subparser ( command "ghc" - (info + (info (PrefetchGHC <$> (PrefetchGHCOptions <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) - <*> optional (toolVersionArgument Nothing (Just GHC)) ) + <*> optional (toolVersionTagArgument Nothing (Just GHC)) ) ( progDesc "Download GHC assets for installation") ) <> command "cabal" - (info + (info (PrefetchCabal <$> 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") ) <> command "hls" - (info + (info (PrefetchHLS <$> 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") ) <> command "stack" - (info + (info (PrefetchStack <$> 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") ) <> diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index 26d7471..a5ee316 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -71,7 +71,7 @@ data RmOptions = RmOptions --[ Parsers ]-- --------------- - + rmParser :: Parser (Either RmCommand RmOptions) rmParser = (Left <$> subparser @@ -103,7 +103,7 @@ rmParser = rmOpts :: Maybe Tool -> Parser RmOptions -rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool +rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index b1f62db..da91381 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -47,6 +47,7 @@ import qualified Data.Text as T #ifndef IS_WINDOWS import qualified System.Posix.Process as SPP #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)") <*> optional (option - (eitherReader toolVersionEither) + (eitherReader ghcVersionTagEither) (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version" <> completer (tagCompleter GHC []) <> (completer $ versionCompleter Nothing GHC) @@ -97,7 +98,7 @@ runOpts = ) <*> optional (option - (eitherReader toolVersionEither) + (eitherReader toolVersionTagEither) (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version" <> completer (tagCompleter Cabal []) <> (completer $ versionCompleter Nothing Cabal) @@ -105,7 +106,7 @@ runOpts = ) <*> optional (option - (eitherReader toolVersionEither) + (eitherReader toolVersionTagEither) (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version" <> completer (tagCompleter HLS []) <> (completer $ versionCompleter Nothing HLS) @@ -113,7 +114,7 @@ runOpts = ) <*> optional (option - (eitherReader toolVersionEither) + (eitherReader toolVersionTagEither) (metavar "STACK_VERSION" <> long "stack" <> help "The stack version" <> completer (tagCompleter Stack []) <> (completer $ versionCompleter Nothing Stack) @@ -218,7 +219,7 @@ runRUN appState action' = do -run :: forall m. +run :: forall m . ( MonadFail m , MonadMask m , MonadCatch m @@ -290,29 +291,33 @@ run RunOptions{..} runAppState leanAppstate runLogger = do pure v cabalVer <- forM runCabalVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Cabal - pure v + pure (_tvVersion v) hlsVer <- forM runHLSVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) HLS - pure v + pure (_tvVersion v) stackVer <- forM runStackVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Stack - pure v + pure (_tvVersion v) pure Toolchain{..} resolveToolchain = do 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 _ -> fail "Internal error" cabalVer <- case runCabalVer of + Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" hlsVer <- case runHLSVer of + Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" stackVer <- case runStackVer of + Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" @@ -347,35 +352,43 @@ run RunOptions{..} runAppState leanAppstate runLogger = do , MergeFileTreeError ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do - forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do - isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt - case mt of - Just (GHC, v) -> do - unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin - (_tvVersion v) - GHCupInternal - False - [] - setTool GHC v tmp - Just (Cabal, v) -> do - unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin - (_tvVersion v) - GHCupInternal - False - setTool Cabal v tmp - Just (Stack, v) -> do - unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin - (_tvVersion v) - GHCupInternal - False - setTool Stack v tmp - Just (HLS, v) -> do - unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin - (_tvVersion v) - GHCupInternal - False - setTool HLS v tmp - _ -> pure () + case ghcVer of + Just v -> do + isInstalled <- lift $ checkIfToolInstalled' GHC v + unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin + (_tvVersion v) + GHCupInternal + False + [] + setGHC' v tmp + _ -> pure () + case cabalVer of + Just v -> do + isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v) + unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin + v + GHCupInternal + False + setCabal' v tmp + _ -> pure () + case stackVer of + Just v -> do + isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v) + unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin + v + GHCupInternal + False + setStack' v tmp + _ -> 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 , MonadThrow m @@ -386,46 +399,47 @@ run RunOptions{..} runAppState leanAppstate runLogger = do -> FilePath -> Excepts '[NotInstalled] (ReaderT LeanAppState m) () installToolChain Toolchain{..} tmp = do - forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do - case mt of - Just (GHC, v) -> setTool GHC v tmp - Just (Cabal, v) -> setTool Cabal v tmp - Just (Stack, v) -> setTool Stack v tmp - Just (HLS, v) -> setTool HLS v tmp - _ -> pure () + case ghcVer of + Just v -> setGHC' v tmp + _ -> pure () + case cabalVer of + Just v -> setCabal' v tmp + _ -> pure () + case stackVer of + Just v -> setStack' v tmp + _ -> pure () + case hlsVer of + Just v -> setHLS' v tmp + _ -> pure () - setTool tool v tmp = - case tool of - GHC -> do + setGHC' v tmp = do void $ liftE $ setGHC v SetGHC_XYZ (Just tmp) void $ liftE $ setGHC v SetGHCOnly (Just tmp) - Cabal -> do - bin <- liftE $ whereIsTool Cabal v + setCabal' v tmp = do + bin <- liftE $ whereIsTool Cabal (mkTVer v) cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp ("cabal" <.> exeExt)) - Stack -> do - bin <- liftE $ whereIsTool Stack v + setStack' v tmp = do + bin <- liftE $ whereIsTool Stack (mkTVer v) cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp ("stack" <.> exeExt)) - HLS -> do + setHLS' v tmp = do Dirs {..} <- getDirs - let v' = _tvVersion v - legacy <- isLegacyHLS v' + legacy <- isLegacyHLS v if legacy then do -- 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) 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 -> lift $ createLink (relativeSymlink tmp bin) (tmp takeFileName bin) - liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp) + liftE $ setHLS v SetHLSOnly (Just tmp) else do - liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp) - liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp) - GHCup -> pure () - + liftE $ setHLS v SetHLS_XYZ (Just tmp) + liftE $ setHLS v SetHLSOnly (Just tmp) + addToPath path = do cEnv <- Map.fromList <$> getEnvironment let paths = ["PATH", "Path"] @@ -466,9 +480,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do pure $ fromGHCupPath tmpDir ("ghcup-" <> intercalate "_" ( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer - <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer - <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . tVerToText) hlsVer - <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer + <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer + <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer + <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer ) ) @@ -482,7 +496,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do data Toolchain = Toolchain { ghcVer :: Maybe GHCTargetVersion - , cabalVer :: Maybe GHCTargetVersion - , hlsVer :: Maybe GHCTargetVersion - , stackVer :: Maybe GHCTargetVersion + , cabalVer :: Maybe Version + , hlsVer :: Maybe Version + , stackVer :: Maybe Version } deriving Show diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index 22f8da6..baeb4ef 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -74,7 +74,7 @@ data SetOptions = SetOptions --[ Parsers ]-- --------------- - + setParser :: Parser (Either SetCommand SetOptions) setParser = (Left <$> subparser @@ -82,7 +82,7 @@ setParser = "ghc" ( SetGHC <$> info - (setOpts (Just GHC) <**> helper) + (setOpts GHC <**> helper) ( progDesc "Set GHC version" <> footerDoc (Just $ text setGHCFooter) ) @@ -91,7 +91,7 @@ setParser = "cabal" ( SetCabal <$> info - (setOpts (Just Cabal) <**> helper) + (setOpts Cabal <**> helper) ( progDesc "Set Cabal version" <> footerDoc (Just $ text setCabalFooter) ) @@ -100,7 +100,7 @@ setParser = "hls" ( SetHLS <$> info - (setOpts (Just HLS) <**> helper) + (setOpts HLS <**> helper) ( progDesc "Set haskell-language-server version" <> footerDoc (Just $ text setHLSFooter) ) @@ -109,14 +109,14 @@ setParser = "stack" ( SetStack <$> info - (setOpts (Just Stack) <**> helper) + (setOpts Stack <**> helper) ( progDesc "Set stack version" <> footerDoc (Just $ text setStackFooter) ) ) ) ) - <|> (Right <$> setOpts Nothing) + <|> (Right <$> setOpts GHC) where setGHCFooter :: String setGHCFooter = [s|Discussion: @@ -137,22 +137,25 @@ setParser = Sets the the current haskell-language-server version.|] -setOpts :: Maybe Tool -> Parser SetOptions +setOpts :: Tool -> Parser SetOptions setOpts tool = SetOptions <$> (fromMaybe SetRecommended <$> optional (setVersionArgument (Just ListInstalled) tool)) -setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion +setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion setVersionArgument criteria tool = argument (eitherReader setEither) (metavar "VERSION|TAG|next" - <> completer (tagCompleter (fromMaybe GHC tool) ["next"]) - <> foldMap (completer . versionCompleter criteria) tool) + <> completer (tagCompleter tool ["next"]) + <> (completer . versionCompleter criteria) tool) where setEither s' = parseSet 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 "next" -> Right SetNext other -> Left $ "Unknown tag/version " <> other @@ -261,9 +264,9 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of (Right sopts) -> do runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") setGHC' sopts - (Left (SetGHC sopts)) -> setGHC' sopts + (Left (SetGHC sopts)) -> setGHC' sopts (Left (SetCabal sopts)) -> setCabal' sopts - (Left (SetHLS sopts)) -> setHLS' sopts + (Left (SetHLS sopts)) -> setHLS' sopts (Left (SetStack sopts)) -> setStack' sopts where @@ -271,7 +274,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of -> m ExitCode setGHC' SetOptions{ sToolVer } = 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 v <- liftE $ fst <$> fromVersion' sToolVer GHC liftE $ setGHC v SetGHCOnly Nothing @@ -291,17 +294,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of -> m ExitCode setCabal' SetOptions{ sToolVer } = 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 v <- liftE $ fst <$> fromVersion' sToolVer Cabal liftE $ setCabal (_tvVersion v) pure v ) >>= \case - VRight GHCTargetVersion{..} -> do + VRight v -> do runLogger $ logInfo $ - "Cabal " <> prettyVer _tvVersion <> " successfully set as default version" + "Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version" pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e @@ -311,17 +314,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of -> m ExitCode setHLS' SetOptions{ sToolVer } = 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 v <- liftE $ fst <$> fromVersion' sToolVer HLS liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing pure v ) >>= \case - VRight GHCTargetVersion{..} -> do + VRight v -> do runLogger $ logInfo $ - "HLS " <> prettyVer _tvVersion <> " successfully set as default version" + "HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version" pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e @@ -332,17 +335,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of -> m ExitCode setStack' SetOptions{ sToolVer } = 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 v <- liftE $ fst <$> fromVersion' sToolVer Stack liftE $ setStack (_tvVersion v) pure v ) >>= \case - VRight GHCTargetVersion{..} -> do + VRight v -> do runLogger $ logInfo $ - "Stack " <> prettyVer _tvVersion <> " successfully set as default version" + "Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version" pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs index ed86697..152021c 100644 --- a/app/ghcup/GHCup/OptParse/Whereis.hs +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -75,14 +75,14 @@ data WhereisOptions = WhereisOptions { --[ Parsers ]-- --------------- - + whereisP :: Parser WhereisCommand whereisP = subparser - (commandGroup "Tools locations:" <> + (commandGroup "Tools locations:" <> command "ghc" (WhereisTool GHC <$> info - ( optional (toolVersionArgument Nothing (Just GHC)) <**> helper ) + ( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper ) ( progDesc "Get GHC location" <> footerDoc (Just $ text whereisGHCFooter )) ) @@ -90,7 +90,7 @@ whereisP = subparser command "cabal" (WhereisTool Cabal <$> info - ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ) + ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper ) ( progDesc "Get cabal location" <> footerDoc (Just $ text whereisCabalFooter )) ) @@ -98,7 +98,7 @@ whereisP = subparser command "hls" (WhereisTool HLS <$> info - ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ) + ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper ) ( progDesc "Get HLS location" <> footerDoc (Just $ text whereisHLSFooter )) ) @@ -106,7 +106,7 @@ whereisP = subparser command "stack" (WhereisTool Stack <$> info - ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ) + ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ) ( progDesc "Get stack location" <> footerDoc (Just $ text whereisStackFooter )) ) @@ -268,7 +268,7 @@ whereis :: ( Monad m whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do Dirs{ .. } <- runReaderT getDirs leanAppstate case (whereisCommand, whereisOptions) of - (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) -> + (WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) -> runLeanWhereIs leanAppstate (do loc <- liftE $ whereIsTool tool v if directory @@ -282,6 +282,20 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e 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 runWhereIs runAppState (do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 290aadb..1957e72 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -236,7 +236,7 @@ Report bugs at |] | Just False <- optVerbose -> pure () | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do - newTools <- lift checkForUpdates + newTools <- lift checkForUpdates forM_ newTools $ \newTool@(t, l) -> do -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283 alreadyInstalling' <- alreadyInstalling optCommand newTool @@ -277,7 +277,7 @@ Report bugs at |] runAppState action' = do s' <- liftIO appState runReaderT action' s' - + ----------------- -- Run command -- @@ -337,14 +337,14 @@ Report bugs at |] alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver 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 })) - (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver + (GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver 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 })) - (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver - alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True + (HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver + alreadyInstalling (Upgrade {}) (GHCup, _) = pure True alreadyInstalling _ _ = pure False cmp' :: ( HasLog env