diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs index 652d850..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) @@ -71,15 +71,16 @@ changelogP = "cabal" -> Right Cabal "ghcup" -> Right GHCup "stack" -> Right Stack + "hls" -> Right HLS e -> Left e ) ) - (short 't' <> long "tool" <> metavar "" <> help + (short 't' <> long "tool" <> metavar "" <> help "Open changelog for given tool (default: ghc)" <> completer toolCompleter ) ) - <*> optional (toolVersionArgument Nothing Nothing) + <*> optional (toolVersionTagArgument Nothing Nothing) @@ -116,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 95fde6b..90ef768 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 @@ -665,7 +677,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 @@ -677,6 +689,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 89b8157..3da11f1 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -401,7 +401,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 91669ab..da91381 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module GHCup.OptParse.Run where @@ -46,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 ) @@ -88,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) @@ -96,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) @@ -104,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) @@ -112,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) @@ -217,7 +219,7 @@ runRUN appState action' = do -run :: forall m. +run :: forall m . ( MonadFail m , MonadMask m , MonadCatch m @@ -233,12 +235,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = do r <- if not runQuick then runRUN runAppState $ do 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 pure tmp else runLeanRUN leanAppstate $ do toolchain <- resolveToolchain - tmp <- liftIO $ createTmpDir toolchain + tmp <- lift $ createTmpDir toolchain liftE $ installToolChain toolchain tmp pure tmp case r of @@ -268,17 +274,6 @@ run RunOptions{..} runAppState leanAppstate runLogger = do 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 resolveToolchainFull :: ( MonadFail m , MonadThrow m @@ -296,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" @@ -353,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 @@ -392,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"] @@ -443,16 +451,38 @@ run RunOptions{..} runAppState leanAppstate runLogger = do liftIO $ setEnv pathVar newPath return envWithNewPath - predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = - liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp "ghcup-none")) + createTmpDir :: ( MonadUnliftIO m + , MonadCatch m + , 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 - tmp <- getTemporaryDirectory - pure $ tmp + Dirs { tmpDir } <- getDirs + 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 ) ) @@ -466,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 5e48d25..164454c 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -238,7 +238,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 @@ -279,7 +279,7 @@ Report bugs at |] runAppState action' = do s' <- liftIO appState runReaderT action' s' - + ----------------- -- Run command -- @@ -339,16 +339,16 @@ 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 = GHC.SourceDist 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 = HLS.SourceDist tver })) - (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver + (HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist 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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 0e52f11..a629add 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -137,7 +137,7 @@ data AlreadyInstalled = AlreadyInstalled Tool Version instance Pretty AlreadyInstalled where 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 "'") diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 39af732..75f4083 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -407,6 +407,9 @@ data AppState = AppState instance NFData AppState +fromAppState :: AppState -> LeanAppState +fromAppState AppState {..} = LeanAppState {..} + data LeanAppState = LeanAppState { settings :: Settings , dirs :: Dirs