{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module GHCup.OptParse.Common where import GHCup import GHCup.Download import GHCup.Errors import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils import GHCup.Prelude import GHCup.Prelude.Process import GHCup.Prelude.Logger import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent import Control.Concurrent.Async import Control.Exception.Safe import Control.Monad.Identity (Identity(..)) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Reader import Data.Aeson #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as KM import qualified Data.Aeson.KeyMap as KM #else import qualified Data.HashMap.Strict as KM #endif import Data.ByteString.Lazy ( ByteString ) import Data.Bifunctor import Data.Char import Data.Either import Data.Functor import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix ) import Data.Maybe import Data.Text ( Text ) import Data.Time.Calendar ( Day ) import Data.Time.Format ( parseTimeM, defaultTimeLocale ) import Data.Versions import Data.Void import qualified Data.Vector as V import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) import Safe import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag ) import URI.ByteString hiding (parseURI) import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as LE import qualified Data.Text.Lazy as LT import qualified Text.Megaparsec as MP import qualified System.FilePath.Posix as FP import GHCup.Version import Control.Exception (evaluate) import qualified Cabal.Config as CC ------------- --[ Types ]-- ------------- -- a superset of ToolVersion data SetToolVersion = SetGHCVersion GHCTargetVersion | SetToolVersion Version | SetToolTag Tag | SetToolDay Day | SetRecommended | SetNext deriving (Eq, Show) prettyToolVer :: ToolVersion -> String prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' prettyToolVer (ToolTag t) = show t prettyToolVer (ToolDay day) = show day toSetToolVer :: Maybe ToolVersion -> SetToolVersion toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' toSetToolVer (Just (ToolTag t')) = SetToolTag t' toSetToolVer (Just (ToolDay d')) = SetToolDay d' toSetToolVer Nothing = SetRecommended -------------- --[ Parser ]-- -------------- toolVersionTagArgument :: [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) where mv (Just GHC) = "GHC_VERSION|TAG|RELEASE_DATE" mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE" mv _ = "VERSION|TAG|RELEASE_DATE" parser (Just GHC) = ghcVersionTagEither parser Nothing = ghcVersionTagEither parser _ = toolVersionTagEither versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version versionParser' criteria tool = argument (eitherReader (first show . version . T.pack)) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) ghcVersionArgument :: [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 -- | A switch that can be enabled using --foo and disabled using --no-foo. -- -- The option modifier is applied to only the option that is *not* enabled -- by default. For example: -- -- > invertableSwitch "recursive" True (help "do not recurse into directories") -- -- This example makes --recursive enabled by default, so -- the help is shown only for --no-recursive. invertableSwitch :: String -- ^ long option -> Maybe Char -- ^ short option for the non-default option -> Bool -- ^ is switch enabled by default? -> Mod FlagFields Bool -- ^ option modifier -> Parser (Maybe Bool) invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv (if defv then mempty else optmod) (if defv then optmod else mempty) -- | Allows providing option modifiers for both --foo and --no-foo. invertableSwitch' :: String -- ^ long option (eg "foo") -> Maybe Char -- ^ short option for the non-default option -> Bool -- ^ is switch enabled by default? -> Mod FlagFields Bool -- ^ option modifier for --foo -> Mod FlagFields Bool -- ^ option modifier for --no-foo -> Parser (Maybe Bool) invertableSwitch' longopt shortopt defv enmod dismod = optional ( flag' True ( enmod <> long longopt <> if defv then mempty else maybe mempty short shortopt) <|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty short shortopt else mempty) ) where nolongopt = "no-" ++ longopt --------------------- --[ Either Parser ]-- --------------------- platformParser :: String -> Either String PlatformRequest platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of Right r -> pure r Left e -> Left $ errorBundlePretty e where archP :: MP.Parsec Void Text Architecture archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32) platformP :: MP.Parsec Void Text PlatformRequest platformP = choice' [ (`PlatformRequest` FreeBSD) <$> (archP <* MP.chunk "-") <*> ( MP.chunk "portbld" *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) <|> pure Nothing ) <* MP.chunk "-freebsd" ) , (`PlatformRequest` Darwin) <$> (archP <* MP.chunk "-") <*> ( MP.chunk "apple" *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) <|> pure Nothing ) <* MP.chunk "-darwin" ) , (\a d mv -> PlatformRequest a (Linux d) mv) <$> (archP <* MP.chunk "-") <*> distroP <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing ) <* MP.chunk "-linux" ) ] distroP :: MP.Parsec Void Text LinuxDistro distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) uriParser :: String -> Either String URI uriParser = first show . parseURI . UTF8.fromString absolutePathParser :: FilePath -> Either String FilePath absolutePathParser f = case isValid f && isAbsolute f of True -> Right $ normalise f False -> Left "Please enter a valid absolute filepath." isolateParser :: FilePath -> Either String FilePath isolateParser f = case isValid f && isAbsolute f of True -> Right $ normalise f False -> Left "Please enter a valid filepath for isolate dir." -- this accepts cross prefix ghcVersionTagEither :: String -> Either String ToolVersion ghcVersionTagEither s' = second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') -- this ignores cross prefix toolVersionTagEither :: String -> Either String ToolVersion toolVersionTagEither s' = second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') tagEither :: String -> Either String Tag tagEither s' = case fmap toLower s' of "recommended" -> Right Recommended "latest" -> Right Latest "latest-prerelease" -> Right LatestPrerelease "latest-nightly" -> Right LatestNightly ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of Right x -> Right (Base x) Left _ -> Left $ "Invalid PVP version for base " <> ver' other -> Left $ "Unknown tag " <> other 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' <* MP.eof) "" . T.pack toolParser :: String -> Either String Tool toolParser s' | t == T.pack "ghc" = Right GHC | t == T.pack "cabal" = Right Cabal | t == T.pack "hls" = Right HLS | t == T.pack "stack" = Right Stack | otherwise = Left ("Unknown tool: " <> s') where t = T.toLower (T.pack s') dayParser :: String -> Either String Day dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s criteriaParser :: String -> Either String ListCriteria criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True | t == T.pack "set" = Right $ ListSet True | t == T.pack "available" = Right $ ListAvailable True | t == T.pack "+installed" = Right $ ListInstalled True | t == T.pack "+set" = Right $ ListSet True | t == T.pack "+available" = Right $ ListAvailable True | t == T.pack "-installed" = Right $ ListInstalled False | t == T.pack "-set" = Right $ ListSet False | t == T.pack "-available" = Right $ ListAvailable False | otherwise = Left ("Unknown criteria: " <> s') where t = T.toLower (T.pack s') keepOnParser :: String -> Either String KeepDirs keepOnParser s' | t == T.pack "always" = Right Always | t == T.pack "errors" = Right Errors | t == T.pack "never" = Right Never | otherwise = Left ("Unknown keep value: " <> s') where t = T.toLower (T.pack s') downloaderParser :: String -> Either String Downloader downloaderParser s' | t == T.pack "curl" = Right Curl | t == T.pack "wget" = Right Wget #if defined(INTERNAL_DOWNLOADER) | t == T.pack "internal" = Right Internal #endif | otherwise = Left ("Unknown downloader value: " <> s') where t = T.toLower (T.pack s') gpgParser :: String -> Either String GPGSetting gpgParser s' | t == T.pack "strict" = Right GPGStrict | t == T.pack "lax" = Right GPGLax | t == T.pack "none" = Right GPGNone | otherwise = Left ("Unknown gpg setting value: " <> s') where t = T.toLower (T.pack s') overWriteVersionParser :: String -> Either String [VersionPattern] overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack where versionPattern :: MP.Parsec Void Text VersionPattern versionPattern = do str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%') if str' /= mempty then pure (S str') else fmap (const CabalVer) v_cabal <|> fmap (const GitBranchName) b_name <|> fmap (const GitHashShort) s_hash <|> fmap (const GitHashLong) l_hash <|> fmap (const GitDescribe) g_desc <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k" where v_cabal = MP.chunk "%v" b_name = MP.chunk "%b" s_hash = MP.chunk "%h" l_hash = MP.chunk "%H" g_desc = MP.chunk "%g" ------------------ --[ Completers ]-- ------------------ toolCompleter :: Completer toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"] gitFileUri :: [String] -> Completer gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add) urlSourceCompleter :: Completer urlSourceCompleter = mkCompleter $ urlSourceCompleter' [] urlSourceCompleter' :: [String] -> String -> IO [String] urlSourceCompleter' add str' = do let static = ["GHCupURL", "StackSetupURL"] file <- fileUri' add str' pure $ static ++ file fileUri :: Completer fileUri = mkCompleter $ fileUri' [] fileUri' :: [String] -> String -> IO [String] fileUri' add = \case "" -> do pwd <- getCurrentDirectory pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add xs | "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$> case stripPrefix "file://" xs of Nothing -> pure [] Just r -> do pwd <- getCurrentDirectory dirs <- compgen "directory" r ["-S", "/"] files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r [] pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else []) | xs `isPrefixOf` "file:///" -> pure ["file:///"] | xs `isPrefixOf` "https://" -> pure ["https://"] | xs `isPrefixOf` "http://" -> pure ["http://"] | otherwise -> pure [] where compgen :: String -> String -> [String] -> IO [String] compgen action' r opts = do let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r] result <- tryIO $ readProcess "bash" ["-c", cmd] "" return . lines . either (const []) id $ result -- | Strongly quote the string we pass to compgen. -- -- We need to do this so bash doesn't expand out any ~ or other -- chars we want to complete on, or emit an end of line error -- when seeking the close to the quote. -- -- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote requote :: String -> String requote s = let -- Bash doesn't appear to allow "mixed" escaping -- in bash completions. So we don't have to really -- worry about people swapping between strong and -- weak quotes. unescaped = case s of -- It's already strongly quoted, so we -- can use it mostly as is, but we must -- ensure it's closed off at the end and -- there's no single quotes in the -- middle which might confuse bash. ('\'': rs) -> unescapeN rs -- We're weakly quoted. ('"': rs) -> unescapeD rs -- We're not quoted at all. -- We need to unescape some characters like -- spaces and quotation marks. elsewise -> unescapeU elsewise in strong unescaped where strong ss = '\'' : foldr go "'" ss where -- If there's a single quote inside the -- command: exit from the strong quote and -- emit it the quote escaped, then resume. go '\'' t = "'\\''" ++ t go h t = h : t -- Unescape a strongly quoted string -- We have two recursive functions, as we -- can enter and exit the strong escaping. unescapeN = goX where goX ('\'' : xs) = goN xs goX (x : xs) = x : goX xs goX [] = [] goN ('\\' : '\'' : xs) = '\'' : goN xs goN ('\'' : xs) = goX xs goN (x : xs) = x : goN xs goN [] = [] -- Unescape an unquoted string unescapeU = goX where goX [] = [] goX ('\\' : x : xs) = x : goX xs goX (x : xs) = x : goX xs -- Unescape a weakly quoted string unescapeD = goX where -- Reached an escape character goX ('\\' : x : xs) -- If it's true escapable, strip the -- slashes, as we're going to strong -- escape instead. | x `elem` ("$`\"\\\n" :: String) = x : goX xs | otherwise = '\\' : x : goX xs -- We've ended quoted section, so we -- don't recurse on goX, it's done. goX ('"' : xs) = xs -- Not done, but not a special character -- just continue the fold. goX (x : xs) = x : goX xs goX [] = [] tagCompleter :: Tool -> [String] -> Completer tagCompleter tool add = listIOCompleter $ do dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False , consoleOutter = mempty , fileOutter = mempty , fancyColors = False } let appState = LeanAppState (defaultSettings { noNetwork = True }) dirs' defaultKeyBindings loggerConfig mpFreq <- flip runReaderT appState . runE $ platformRequest forFold mpFreq $ \pfreq -> do mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq case mGhcUpInfo of VRight ghcupInfo -> do let allTags = filter (/= Old) $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool) pure $ nub $ (add ++) $ fmap tagToString allTags VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add) versionCompleter :: [ListCriteria] -> Tool -> Completer versionCompleter criteria tool = versionCompleter' criteria tool (const True) versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer versionCompleter' criteria tool filter' = listIOCompleter $ do dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False , consoleOutter = mempty , fileOutter = mempty , fancyColors = False } let settings = defaultSettings { noNetwork = True } let leanAppState = LeanAppState settings dirs' defaultKeyBindings loggerConfig mpFreq <- flip runReaderT leanAppState . runE $ platformRequest forFold mpFreq $ \pfreq -> do mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq forFold mGhcUpInfo $ \ghcupInfo -> do let appState = AppState settings dirs' defaultKeyBindings ghcupInfo pfreq loggerConfig runEnv = flip runReaderT appState installedVersions <- runEnv $ listVersions (Just tool) criteria False False (Nothing, Nothing) return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions toolDlCompleter :: Tool -> Completer toolDlCompleter tool = mkCompleter $ \case "" -> pure (initUrl tool <> ["https://", "http://", "file:///"]) word | "file://" `isPrefixOf` word -> fileUri' [] word -- downloads.haskell.org | "https://downloads.haskell.org/" `isPrefixOf` word -> fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word -- github releases | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word , let xs = splitPath word , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') -> fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server" | "https://github.com/commercialhaskell/stack/releases/download/" == word , let xs = splitPath word , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') -> fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack" -- github release assets | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word , let xs = splitPath word , (length xs == 7 && last word == '/') || length xs == 8 , let rel = xs !! 6 , length rel > 1 -> do fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel) | "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word , let xs = splitPath word , (length xs == 7 && last word == '/') || length xs == 8 , let rel = xs !! 6 , length rel > 1 -> do fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel) -- github | "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"] | "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"] | "https://g" `isPrefixOf` word , tool == Stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"] | "https://g" `isPrefixOf` word , tool == HLS -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"] | "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool | "h" `isPrefixOf` word -> pure $ initUrl tool | word `isPrefixOf` "file:///" -> pure ["file:///"] | word `isPrefixOf` "https://" -> pure ["https://"] | word `isPrefixOf` "http://" -> pure ["http://"] | otherwise -> pure [] where initUrl :: Tool -> [String] initUrl GHC = [ "https://downloads.haskell.org/~ghc/" , "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/" ] initUrl Cabal = [ "https://downloads.haskell.org/~cabal/" , "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/" ] initUrl GHCup = [ "https://downloads.haskell.org/~ghcup/" ] initUrl HLS = [ "https://github.com/haskell/haskell-language-server/releases/download/" , "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/" ] initUrl Stack = [ "https://github.com/commercialhaskell/stack/releases/download/" , "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/" ] completePrefix :: String -- ^ url, e.g. 'https://github.com/haskell/haskell-languag' -> String -- ^ match, e.g. 'haskell-language-server' -> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server' completePrefix url match = let base = FP.takeDirectory url fn = FP.takeFileName url in if fn `isPrefixOf` match then base <> "/" <> match else url prefixMatch :: String -> [String] -> [String] prefixMatch pref = filter (pref `isPrefixOf`) fromHRef :: String -> IO [String] fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout -> pure . fmap (T.unpack . decUTF8Safe' . fromAttrib "href") . filter isTagOpen . filter (~== ("" :: String)) . parseTags $ stdout withCurl :: String -- ^ url -> Int -- ^ delay -> (ByteString -> IO [String]) -- ^ callback -> IO [String] withCurl url delay cb = do let limit = threadDelay delay race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case Right (CapturedProcess {_exitCode, _stdOut}) -> do case _exitCode of ExitSuccess -> (try @_ @SomeException . cb $ _stdOut) >>= \case Left _ -> pure [] Right r' -> do r <- try @_ @SomeException . evaluate . force $ r' either (\_ -> pure []) pure r ExitFailure _ -> pure [] Left _ -> pure [] getGithubReleases :: String -> String -> IO [String] getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do Just xs <- pure $ decode' @Array stdout fmap V.toList $ forM xs $ \x -> do (Object r) <- pure x Just (String name) <- pure $ KM.lookup (mkval "tag_name") r pure $ T.unpack name where url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases" getGithubAssets :: String -> String -> String -> IO [String] getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do Just xs <- pure $ decode' @Object stdout Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs as <- fmap V.toList $ forM assets $ \val -> do (Object asset) <- pure val Just (String name) <- pure $ KM.lookup (mkval "name") asset pure $ T.unpack name pure as where url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag #if MIN_VERSION_aeson(2,0,0) mkval = KM.fromString #else mkval = id #endif ----------------- --[ Utilities ]-- ----------------- fromVersion :: ( HasLog env , MonadFail m , MonadReader env m , HasGHCupInfo env , HasDirs env , MonadThrow m , MonadIO m , MonadCatch m ) => Maybe ToolVersion -> Tool -> Excepts '[ TagNotFound , DayNotFound , NextVerNotFound , NoToolVersionSet ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion tv = fromVersion' (toSetToolVer tv) fromVersion' :: ( HasLog env , MonadFail m , MonadReader env m , HasGHCupInfo env , HasDirs env , MonadThrow m , MonadIO m , MonadCatch m ) => SetToolVersion -> Tool -> Excepts '[ TagNotFound , DayNotFound , NextVerNotFound , NoToolVersionSet ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion' SetRecommended tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetGHCVersion v) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo v tool dls case pvp $ prettyVer (_tvVersion v) of -- need to be strict here Left _ -> pure (v, vi) Right pvpIn -> lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case Just (pvp_, vi', mt) -> do v' <- lift $ pvpToVersion pvp_ "" when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') pure (GHCTargetVersion mt v', Just vi') Nothing -> pure (v, vi) fromVersion' (SetToolVersion (mkTVer -> v)) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo v tool dls case pvp $ prettyVer (_tvVersion v) of -- need to be strict here Left _ -> pure (v, vi) Right pvpIn -> lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case Just (pvp_, vi', mt) -> do v' <- lift $ pvpToVersion pvp_ "" when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') pure (GHCTargetVersion mt v', Just vi') Nothing -> pure (v, vi) fromVersion' (SetToolTag Latest) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool fromVersion' (SetToolDay day) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap id Just <$> case getByReleaseDay dls tool day of Left ad -> throwE $ DayNotFound day tool ad Right v -> pure v fromVersion' (SetToolTag LatestPrerelease) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool fromVersion' (SetToolTag LatestNightly) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool fromVersion' (SetToolTag Recommended) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetToolTag (Base pvp'')) GHC = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC fromVersion' SetNext tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo next <- case tool of GHC -> do set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool ghcs <- rights <$> lift getInstalledGHCs (headMay . tail . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set) . cycle . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y)) . filter (\GHCTargetVersion {..} -> isNothing _tvTarget) $ ghcs) ?? NoToolVersionSet tool Cabal -> do set <- cabalSet !? NoToolVersionSet tool cabals <- rights <$> lift getInstalledCabals (fmap (GHCTargetVersion Nothing) . headMay . tail . dropWhile (/= set) . cycle . sort $ cabals) ?? NoToolVersionSet tool HLS -> do set <- hlsSet !? NoToolVersionSet tool hlses <- rights <$> lift getInstalledHLSs (fmap (GHCTargetVersion Nothing) . headMay . tail . dropWhile (/= set) . cycle . sort $ hlses) ?? NoToolVersionSet tool Stack -> do set <- stackSet !? NoToolVersionSet tool stacks <- rights <$> lift getInstalledStacks (fmap (GHCTargetVersion Nothing) . headMay . tail . dropWhile (/= set) . cycle . sort $ stacks) ?? NoToolVersionSet tool GHCup -> fail "GHCup cannot be set" let vi = getVersionInfo next tool dls pure (next, vi) fromVersion' (SetToolTag t') tool = throwE $ TagNotFound t' tool checkForUpdates :: ( MonadReader env m , HasGHCupInfo env , HasDirs env , HasPlatformReq env , MonadCatch m , HasLog env , MonadThrow m , MonadIO m , MonadFail m ) => m [(Tool, GHCTargetVersion)] checkForUpdates = do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> forMM (getLatest dls t) $ \(l, _) -> do let mver = latestInstalled t forMM mver $ \ver -> if (l > ver) then pure $ Just (t, l) else pure Nothing pure $ catMaybes (ghcup:otherTools) where forMM a f = fmap join $ forM a f logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () logGHCPostRm ghcVer = do cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") (runIdentity . CC.cfgStoreDir <$> CC.readConfig) let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir parseUrlSource :: String -> Either String URLSource parseUrlSource "GHCupURL" = pure GHCupURL parseUrlSource "StackSetupURL" = pure StackSetupURL parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') parseNewUrlSource :: String -> Either String NewURLSource parseNewUrlSource "GHCupURL" = pure NewGHCupURL parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s')