ghcup 0.1.17.5 → 0.1.17.6
raw patch · 21 files changed
+878/−286 lines, 21 filesdep +tagsoupdep ~generic-arbitrarydep ~hspecdep ~megaparsecPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: tagsoup
Dependency ranges changed: generic-arbitrary, hspec, megaparsec, optparse-applicative, unordered-containers
API changes (from Hackage documentation)
- GHCup: installHLSPostInst :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadCatch m, MonadMask m, MonadFail m, MonadUnliftIO m) => Maybe FilePath -> Version -> Excepts '[NotInstalled] m ()
+ GHCup.Requirements: rawRequirements :: Requirements -> Text
- GHCup.Types: AddSource :: Either GHCupInfo URI -> URLSource
+ GHCup.Types: AddSource :: [Either GHCupInfo URI] -> URLSource
- GHCup.Types: OwnSource :: URI -> URLSource
+ GHCup.Types: OwnSource :: [Either GHCupInfo URI] -> URLSource
Files
- CHANGELOG.md +13/−1
- app/ghcup/GHCup/OptParse.hs +12/−7
- app/ghcup/GHCup/OptParse/ChangeLog.hs +1/−0
- app/ghcup/GHCup/OptParse/Common.hs +290/−5
- app/ghcup/GHCup/OptParse/Compile.hs +25/−14
- app/ghcup/GHCup/OptParse/Config.hs +56/−39
- app/ghcup/GHCup/OptParse/Install.hs +121/−41
- app/ghcup/GHCup/OptParse/List.hs +4/−2
- app/ghcup/GHCup/OptParse/Prefetch.hs +4/−4
- app/ghcup/GHCup/OptParse/Run.hs +206/−91
- app/ghcup/GHCup/OptParse/ToolRequirements.hs +44/−4
- app/ghcup/GHCup/OptParse/Upgrade.hs +1/−0
- app/ghcup/Main.hs +7/−5
- data/config.yaml +10/−4
- ghcup.cabal +18/−15
- lib/GHCup.hs +0/−25
- lib/GHCup/Download.hs +16/−19
- lib/GHCup/Requirements.hs +6/−0
- lib/GHCup/Types.hs +2/−2
- lib/GHCup/Types/JSON.hs +33/−1
- lib/GHCup/Utils/Dirs.hs +9/−7
CHANGELOG.md view
@@ -1,10 +1,22 @@ # Revision history for ghcup +## 0.1.17.6 -- 2022-03-18++* Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)+* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)+* Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323)+* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329)+* Fix bug with isolated installation of not previously installed versions+* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330)+* Fix serious bug in `ghcup list --raw-format -t <tool> -c installed`+* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328)+* Fix max path issues on windows with `ghcup run`+ ## 0.1.17.5 -- 2022-02-26 * Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137) * Support installation of dynamic HLS bindists wrt [HLS #2675](https://github.com/haskell/haskell-language-server/pull/2675) and [#237](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/237)-* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/311)+* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/311) * Add support for quilt-style patches wrt [#230](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/230), by James Hobson * Fix redundant upgrade warnings in `ghcup upgrade` * Fix `ghcup whereis ghc` for non-standard versions wrt [#289](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/289)
app/ghcup/GHCup/OptParse.hs view
@@ -98,7 +98,7 @@ #ifndef DISABLE_UPGRADE | Upgrade UpgradeOpts Bool #endif- | ToolRequirements+ | ToolRequirements ToolReqOpts | ChangeLog ChangeLogOptions | Nuke #if defined(BRICK)@@ -113,8 +113,8 @@ opts :: Parser Options opts = Options- <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")- <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")+ <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")+ <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)") <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal)) <*> optional (option@@ -124,9 +124,10 @@ <> metavar "URL" <> help "Alternative ghcup download info url" <> internal+ <> completer fileUri ) )- <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))+ <*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)")) <*> optional (option (eitherReader keepOnParser) ( long "keep"@@ -134,6 +135,7 @@ <> help "Keep build directories? (default: errors)" <> hidden+ <> completer (listCompleter ["always", "errors", "never"]) )) <*> optional (option (eitherReader downloaderParser)@@ -142,20 +144,23 @@ <> metavar "<internal|curl|wget>" <> help "Downloader to use (default: internal)"+ <> completer (listCompleter ["internal", "curl", "wget"]) #else <> metavar "<curl|wget>" <> help "Downloader to use (default: curl)"+ <> completer (listCompleter ["curl", "wget"]) #endif <> hidden ))- <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")+ <*> invertableSwitch "offline" (Just 'o') False (help "Don't do any network calls, trying cached assets and failing if missing.") <*> optional (option (eitherReader gpgParser) ( long "gpg" <> metavar "<strict|lax|none>" <> help "GPG verification (default: none)"+ <> completer (listCompleter ["strict", "lax", "none"]) )) <*> com where@@ -284,8 +289,8 @@ ((\_ -> DInfo) <$> info helper (progDesc "Show debug info")) <> command "tool-requirements"- ( (\_ -> ToolRequirements)- <$> info helper+ ( ToolRequirements+ <$> info (toolReqP <**> helper) (progDesc "Show the requirements for ghc/cabal") ) <> command
app/ghcup/GHCup/OptParse/ChangeLog.hs view
@@ -76,6 +76,7 @@ ) (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help "Open changelog for given tool (default: ghc)"+ <> completer toolCompleter ) ) <*> optional (toolVersionArgument Nothing Nothing)
app/ghcup/GHCup/OptParse/Common.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NumericUnderscores #-} module GHCup.OptParse.Common where @@ -14,36 +16,55 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Utils+import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude +import Control.DeepSeq+import Control.Concurrent+import Control.Concurrent.Async import Control.Exception.Safe #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 )+import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix ) import Data.Maybe import Data.Text ( Text ) import Data.Versions hiding ( str ) 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.Directory+import System.Process ( readProcess ) import System.FilePath+import Text.HTML.TagSoup hiding ( Tag ) import URI.ByteString import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Text.Megaparsec as MP+import qualified System.FilePath.Posix as FP import GHCup.Version+import Control.Exception (evaluate) -------------@@ -117,7 +138,7 @@ -- the help is shown only for --no-recursive. invertableSwitch :: String -- ^ long option- -> Char -- ^ short option for the non-default option+ -> Maybe Char -- ^ short option for the non-default option -> Bool -- ^ is switch enabled by default? -> Mod FlagFields Bool -- ^ option modifier -> Parser (Maybe Bool)@@ -128,14 +149,14 @@ -- | Allows providing option modifiers for both --foo and --no-foo. invertableSwitch' :: String -- ^ long option (eg "foo")- -> Char -- ^ short option for the non-default option+ -> 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 short shortopt)- <|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)+ ( 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@@ -277,6 +298,126 @@ --[ Completers ]-- ------------------ ++toolCompleter :: Completer+toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]++gitFileUri :: [String] -> Completer+gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)++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@@ -332,6 +473,150 @@ installedVersions <- runEnv $ listVersions (Just tool) criteria return $ T.unpack . prettyVer . 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 (~== ("<a href>" :: 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++
app/ghcup/GHCup/OptParse/Compile.hs view
@@ -165,6 +165,7 @@ ) (short 'v' <> long "version" <> metavar "VERSION" <> help "The tool version to compile"+ <> (completer $ versionCompleter Nothing GHC) ) ) <|> (Right <$> (GitBranch <$> option@@ -172,7 +173,10 @@ (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from" ) <*>- optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))+ optional (option str (+ short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"+ <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])+ )) ))) <*> option (eitherReader@@ -185,12 +189,14 @@ <> metavar "BOOTSTRAP_GHC" <> help "The GHC version (or full path) to bootstrap with (must be installed)"+ <> (completer $ versionCompleter Nothing GHC) ) <*> optional (option (eitherReader (readEither @Int)) (short 'j' <> long "jobs" <> metavar "JOBS" <> help "How many jobs to use for make"+ <> (completer $ listCompleter $ fmap show ([1..12] :: [Int])) ) ) <*> optional@@ -198,6 +204,7 @@ str (short 'c' <> long "config" <> metavar "CONFIG" <> help "Absolute path to build config file"+ <> completer (bashCompleter "file") ) ) <*> (optional@@ -206,6 +213,7 @@ (eitherReader uriParser) (long "patch" <> metavar "PATCH_URI" <> help "URI to a patch (https/http/file)"+ <> completer fileUri ) ) <|>@@ -213,6 +221,7 @@ str (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help "Absolute path to patch directory (applies all .patch and .diff files in order using -p1. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)"+ <> completer (bashCompleter "directory") ) ) )@@ -225,12 +234,7 @@ ) ) <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))- <*> flag- False- True- (long "set" <> help- "Set as active version after install"- )+ <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install")) <*> optional (option (eitherReader@@ -238,6 +242,7 @@ ) (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"+ <> (completer $ versionCompleter Nothing GHC) ) ) <*> optional@@ -257,6 +262,7 @@ <> long "isolate" <> metavar "DIR" <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"+ <> completer (bashCompleter "directory") ) ) @@ -269,6 +275,7 @@ ) (short 'v' <> long "version" <> metavar "VERSION" <> help "The tool version to compile"+ <> (completer $ versionCompleter Nothing HLS) ) ) <|> (Right <$> (GitBranch <$> option@@ -276,21 +283,19 @@ (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from" ) <*>- optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))+ optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"+ <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])+ )) ))) <*> optional (option (eitherReader (readEither @Int)) (short 'j' <> long "jobs" <> metavar "JOBS" <> help "How many jobs to use for make"+ <> (completer $ listCompleter $ fmap show ([1..12] :: [Int])) ) )- <*> flag- False- True- (long "set" <> help- "Set as active version after install"- )+ <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install")) <*> optional (option (eitherReader@@ -298,6 +303,7 @@ ) (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"+ <> (completer $ versionCompleter Nothing HLS) ) ) <*> optional@@ -307,6 +313,7 @@ <> long "isolate" <> metavar "DIR" <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"+ <> completer (bashCompleter "directory") ) ) <*> optional@@ -314,6 +321,7 @@ ((fmap Right $ eitherReader uriParser) <|> (fmap Left str)) (long "cabal-project" <> metavar "CABAL_PROJECT" <> help "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."+ <> completer fileUri ) ) <*> optional@@ -321,6 +329,7 @@ (eitherReader uriParser) (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."+ <> completer fileUri ) ) <*> (optional@@ -329,6 +338,7 @@ (eitherReader uriParser) (long "patch" <> metavar "PATCH_URI" <> help "URI to a patch (https/http/file)"+ <> completer fileUri ) ) <|>@@ -336,6 +346,7 @@ str (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"+ <> completer (bashCompleter "directory") ) ) )
app/ghcup/GHCup/OptParse/Config.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExplicitForAll #-} module GHCup.OptParse.Config where @@ -17,6 +18,7 @@ import GHCup.Utils.Prelude import GHCup.Utils.Logger import GHCup.Utils.String.QQ+import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -27,10 +29,11 @@ import Data.Functor import Data.Maybe import Haskus.Utils.Variant.Excepts-import Options.Applicative hiding ( style )+import Options.Applicative hiding ( style, ParseError ) import Options.Applicative.Help.Pretty ( text ) import Prelude hiding ( appendFile ) import System.Exit+import URI.ByteString hiding ( uriParser ) import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8@@ -49,6 +52,7 @@ = ShowConfig | SetConfig String (Maybe String) | InitConfig+ | AddReleaseChannel URI @@ -62,6 +66,7 @@ ( command "init" initP <> command "set" setP -- [set] KEY VALUE at help lhs <> command "show" showP+ <> command "add-release-channel" addP ) <|> argsP -- add show for a single option <|> pure ShowConfig@@ -70,6 +75,8 @@ showP = info (pure ShowConfig) (progDesc "Show current config (default)") setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter)) argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))+ addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))+ (progDesc "Add a release channel from a URI") @@ -114,23 +121,18 @@ formatConfig = UTF8.toString . Y.encode -updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings-updateSettings config' settings = do- settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config'- pure $ mergeConf settings' settings- where- mergeConf :: UserSettings -> Settings -> Settings- mergeConf UserSettings{..} Settings{..} =- let cache' = fromMaybe cache uCache- metaCache' = fromMaybe metaCache uMetaCache- noVerify' = fromMaybe noVerify uNoVerify- keepDirs' = fromMaybe keepDirs uKeepDirs- downloader' = fromMaybe downloader uDownloader- verbose' = fromMaybe verbose uVerbose- urlSource' = fromMaybe urlSource uUrlSource- noNetwork' = fromMaybe noNetwork uNoNetwork- gpgSetting' = fromMaybe gpgSetting uGPGSetting- in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor+updateSettings :: UserSettings -> Settings -> Settings+updateSettings UserSettings{..} Settings{..} =+ let cache' = fromMaybe cache uCache+ metaCache' = fromMaybe metaCache uMetaCache+ noVerify' = fromMaybe noVerify uNoVerify+ keepDirs' = fromMaybe keepDirs uKeepDirs+ downloader' = fromMaybe downloader uDownloader+ verbose' = fromMaybe verbose uVerbose+ urlSource' = fromMaybe urlSource uUrlSource+ noNetwork' = fromMaybe noNetwork uNoNetwork+ gpgSetting' = fromMaybe gpgSetting uGPGSetting+ in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor @@ -140,7 +142,7 @@ -config :: ( Monad m+config :: forall m. ( Monad m , MonadMask m , MonadUnliftIO m , MonadFail m@@ -161,27 +163,42 @@ liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings) pure ExitSuccess - (SetConfig k (Just v)) ->- case v of- "" -> do- runLogger $ logError "Empty values are not allowed"- pure $ ExitFailure 55- _ -> doConfig (k <> ": " <> v <> "\n")+ (SetConfig k mv) -> do+ r <- runE @'[JSONError, ParseError] $ do+ case mv of+ Just "" ->+ throwE $ ParseError "Empty values are not allowed"+ Nothing -> do+ usersettings <- decodeSettings k+ lift $ doConfig usersettings+ pure ()+ Just v -> do+ usersettings <- decodeSettings (k <> ": " <> v <> "\n")+ lift $ doConfig usersettings+ pure ()+ case r of+ VRight _ -> pure ExitSuccess+ VLeft (V (JSONDecodeError e)) -> do+ runLogger $ logError $ "Error decoding config: " <> T.pack e+ pure $ ExitFailure 65+ VLeft _ -> pure $ ExitFailure 65 - (SetConfig json Nothing) -> doConfig json+ AddReleaseChannel uri -> do+ case urlSource settings of+ AddSource xs -> do+ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })+ pure ExitSuccess+ _ -> do+ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })+ pure ExitSuccess where- doConfig val = do- r <- runE @'[JSONError] $ do- settings' <- updateSettings (UTF8.fromString val) settings- path <- liftIO getConfigFilePath- liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)- lift $ runLogger $ logDebug $ T.pack $ show settings'- pure ()+ doConfig :: MonadIO m => UserSettings -> m ()+ doConfig usersettings = do+ let settings' = updateSettings usersettings settings+ path <- liftIO getConfigFilePath+ liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)+ runLogger $ logDebug $ T.pack $ show settings'+ pure () - case r of- VRight _ -> pure ExitSuccess- VLeft (V (JSONDecodeError e)) -> do- runLogger $ logError $ "Error decoding config: " <> T.pack e- pure $ ExitFailure 65- VLeft _ -> pure $ ExitFailure 65+ decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
app/ghcup/GHCup/OptParse/Install.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ViewPatterns #-} module GHCup.OptParse.Install where @@ -189,18 +190,15 @@ (eitherReader uriParser) (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help "Install the specified version from this bindist"+ <> completer (toolDlCompleter (fromMaybe GHC tool)) ) ) <*> (Just <$> toolVersionArgument Nothing tool) ) <|> pure (Nothing, Nothing) )- <*> flag- False- True- (long "set" <> help- "Set as active version after install"- )+ <*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault+ (help $ if not setDefault then "Set as active version after install" else "Don't set as active version after install")) <*> optional (option (eitherReader isolateParser)@@ -208,10 +206,16 @@ <> long "isolate" <> metavar "DIR" <> help "install in an isolated dir instead of the default one"+ <> completer (bashCompleter "directory") ) ) <*> switch (short 'f' <> long "force" <> help "Force install")+ where+ setDefault = case tool of+ Nothing -> False+ Just GHC -> False+ Just _ -> True @@ -253,6 +257,48 @@ , NoToolVersionSet , FileAlreadyExistsError , ProcessError++ , (AlreadyInstalled, ())+ , (UnknownArchive, ())+ , (ArchiveResult, ())+ , (FileDoesNotExistError, ())+ , (CopyError, ())+ , (NotInstalled, ())+ , (DirNotEmpty, ())+ , (NoDownload, ())+ , (NotInstalled, ())+ , (BuildFailed, ())+ , (TagNotFound, ())+ , (DigestError, ())+ , (GPGError, ())+ , (DownloadFailed, ())+ , (TarDirDoesNotExist, ())+ , (NextVerNotFound, ())+ , (NoToolVersionSet, ())+ , (FileAlreadyExistsError, ())+ , (ProcessError, ())++ , (AlreadyInstalled, NotInstalled)+ , (UnknownArchive, NotInstalled)+ , (ArchiveResult, NotInstalled)+ , (FileDoesNotExistError, NotInstalled)+ , (CopyError, NotInstalled)+ , (NotInstalled, NotInstalled)+ , (DirNotEmpty, NotInstalled)+ , (NoDownload, NotInstalled)+ , (NotInstalled, NotInstalled)+ , (BuildFailed, NotInstalled)+ , (TagNotFound, NotInstalled)+ , (DigestError, NotInstalled)+ , (GPGError, NotInstalled)+ , (DownloadFailed, NotInstalled)+ , (TarDirDoesNotExist, NotInstalled)+ , (NextVerNotFound, NotInstalled)+ , (NoToolVersionSet, NotInstalled)+ , (FileAlreadyExistsError, NotInstalled)+ , (ProcessError, NotInstalled)++ , ((), NotInstalled) ] @@ -352,7 +398,7 @@ isolateDir forceInstall )- $ when instSet $ void $ setGHC v SetGHCOnly Nothing+ $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing pure vi Just uri -> do runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do@@ -363,7 +409,7 @@ isolateDir forceInstall )- $ when instSet $ void $ setGHC v SetGHCOnly Nothing+ $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing pure vi ) >>= \case@@ -418,20 +464,22 @@ s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstTool s' instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer Cabal- liftE $ installCabalBin- (_tvVersion v)- isolateDir- forceInstall+ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal+ void $ liftE $ sequenceE (installCabalBin+ v+ isolateDir+ forceInstall+ ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer Cabal- liftE $ installCabalBindist - (DownloadInfo uri Nothing "")- (_tvVersion v)- isolateDir- forceInstall+ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal+ void $ liftE $ sequenceE (installCabalBindist+ (DownloadInfo uri Nothing "")+ v+ isolateDir+ forceInstall+ ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v pure vi ) >>= \case@@ -448,6 +496,14 @@ runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3+ VLeft (V (AlreadyInstalled _ v, ())) -> do+ runLogger $ logWarn $+ "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"+ pure ExitSuccess+ VLeft (V (FileAlreadyExistsError fp, ())) -> do+ runLogger $ logWarn $+ "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."+ pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e@@ -459,21 +515,23 @@ s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstTool s' instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer HLS- liftE $ installHLSBin- (_tvVersion v)- isolateDir- forceInstall+ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS+ void $ liftE $ sequenceE (installHLSBin+ v+ isolateDir+ forceInstall+ ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer HLS+ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS -- TODO: support legacy- liftE $ installHLSBindist- (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")- (_tvVersion v)- isolateDir- forceInstall+ void $ liftE $ sequenceE (installHLSBindist+ (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")+ v+ isolateDir+ forceInstall+ ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing pure vi ) >>= \case@@ -494,6 +552,18 @@ runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3+ VLeft (V (AlreadyInstalled _ v, ())) -> do+ runLogger $ logWarn $+ "HLS ver "+ <> prettyVer v+ <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "+ <> prettyVer v+ <> "'"+ pure ExitSuccess+ VLeft (V (FileAlreadyExistsError fp, ())) -> do+ runLogger $ logWarn $+ "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."+ pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e@@ -505,20 +575,22 @@ s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstTool s' instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer Stack- liftE $ installStackBin- (_tvVersion v)- isolateDir- forceInstall+ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack+ void $ liftE $ sequenceE (installStackBin+ v+ isolateDir+ forceInstall+ ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer Stack- liftE $ installStackBindist- (DownloadInfo uri Nothing "")- (_tvVersion v)- isolateDir- forceInstall+ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack+ void $ liftE $ sequenceE (installStackBindist+ (DownloadInfo uri Nothing "")+ v+ isolateDir+ forceInstall+ ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v pure vi ) >>= \case@@ -532,6 +604,14 @@ "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'" pure ExitSuccess VLeft (V (FileAlreadyExistsError fp)) -> do+ runLogger $ logWarn $+ "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."+ pure $ ExitFailure 3+ VLeft (V (AlreadyInstalled _ v, ())) -> do+ runLogger $ logWarn $+ "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"+ pure ExitSuccess+ VLeft (V (FileAlreadyExistsError fp, ())) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3
app/ghcup/GHCup/OptParse/List.hs view
@@ -69,6 +69,7 @@ (eitherReader toolParser) (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help "Tool to list versions for. Default is all"+ <> completer (toolCompleter) ) ) <*> optional@@ -78,6 +79,7 @@ <> long "show-criteria" <> metavar "<installed|set|available>" <> help "Show only installed/set/available tool versions"+ <> completer (listCompleter ["installed", "set", "available"]) ) ) <*> switch@@ -141,11 +143,11 @@ ) $ lr let cols =- foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows+ foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows lengths = fmap (maximum . fmap strWidth) cols padded = fmap (\xs -> zipWith padTo xs lengths) rows - forM_ padded $ \row -> putStrLn $ unwords row+ forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row where padTo str' x =
app/ghcup/GHCup/OptParse/Prefetch.hs view
@@ -83,7 +83,7 @@ (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/)")))+ <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <*> optional (toolVersionArgument Nothing (Just GHC)) ) ( progDesc "Download GHC assets for installation") )@@ -92,7 +92,7 @@ "cabal" (info (PrefetchCabal- <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))+ <$> 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 )) ( progDesc "Download cabal assets for installation") )@@ -101,7 +101,7 @@ "hls" (info (PrefetchHLS- <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))+ <$> 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 )) ( progDesc "Download HLS assets for installation") )@@ -110,7 +110,7 @@ "stack" (info (PrefetchStack- <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))+ <$> 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 )) ( progDesc "Download stack assets for installation") )
app/ghcup/GHCup/OptParse/Run.hs view
@@ -15,7 +15,7 @@ import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types-import GHCup.Types.Optics ( getDirs )+import GHCup.Types.Optics import GHCup.Utils.Logger import GHCup.Utils.String.QQ @@ -35,7 +35,6 @@ import System.Directory import System.FilePath import System.Environment-import System.IO.Temp import System.Exit import Text.PrettyPrint.HughesPJClass ( prettyShow ) @@ -72,6 +71,7 @@ --------------- + runOpts :: Parser RunOptions runOpts = RunOptions@@ -82,22 +82,34 @@ <*> optional (option (eitherReader toolVersionEither)- (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version")+ (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"+ <> completer (tagCompleter GHC [])+ <> (completer $ versionCompleter Nothing GHC)+ ) ) <*> optional (option (eitherReader toolVersionEither)- (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version")+ (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"+ <> completer (tagCompleter Cabal [])+ <> (completer $ versionCompleter Nothing Cabal)+ ) ) <*> optional (option (eitherReader toolVersionEither)- (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version")+ (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"+ <> completer (tagCompleter HLS [])+ <> (completer $ versionCompleter Nothing HLS)+ ) ) <*> optional (option (eitherReader toolVersionEither)- (metavar "STACK_VERSION" <> long "stack" <> help "The stack version")+ (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"+ <> completer (tagCompleter Stack [])+ <> (completer $ versionCompleter Nothing Stack)+ ) ) <*> optional (option@@ -106,6 +118,7 @@ <> long "bindir" <> metavar "DIR" <> help "directory where to create the tool symlinks (default: newly created system temp dir)"+ <> completer (bashCompleter "directory") ) ) <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))@@ -174,14 +187,16 @@ @RunEffects runRUN :: MonadUnliftIO m- => (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))+ => IO AppState -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a -> m (VEither RunEffects a)-runRUN runAppState =- runAppState+runRUN appState action' = do+ s' <- liftIO appState+ flip runReaderT s' . runResourceT . runE @RunEffects+ $ action' @@ -199,111 +214,183 @@ , MonadUnliftIO m ) => RunOptions- -> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))+ -> IO AppState -> LeanAppState -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode run RunOptions{..} runAppState leanAppstate runLogger = do- tmp <- case runBinDir of- Just bdir -> do- liftIO $ createDirRecursive' bdir- liftIO $ canonicalizePath bdir- Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup")- r <- do- addToolsToDir tmp+ r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool'+ then runRUN runAppState $ do+ toolchain <- liftE resolveToolchainFull+ tmp <- case runBinDir of+ Just bindir -> do+ liftIO $ createDirRecursive' bindir+ liftIO $ canonicalizePath bindir+ Nothing -> do+ d <- liftIO $ predictableTmpDir toolchain+ liftIO $ createDirRecursive' d+ liftIO $ canonicalizePath d+ liftE $ installToolChainFull toolchain tmp+ pure tmp+ else runLeanRUN leanAppstate $ do+ toolchain <- resolveToolchain+ tmp <- case runBinDir of+ Just bindir -> do+ liftIO $ createDirRecursive' bindir+ liftIO $ canonicalizePath bindir+ Nothing -> do+ d <- liftIO $ predictableTmpDir toolchain+ liftIO $ createDirRecursive' d+ liftIO $ canonicalizePath d+ liftE $ installToolChain toolchain tmp+ pure tmp case r of- VRight _ -> do- case runCOMMAND of- [] -> do- liftIO $ putStr tmp- pure ExitSuccess- (cmd:args) -> do- newEnv <- liftIO $ addToPath tmp+ VRight tmp -> do+ case runCOMMAND of+ [] -> do+ liftIO $ putStr tmp+ pure ExitSuccess+ (cmd:args) -> do+ newEnv <- liftIO $ addToPath tmp #ifndef IS_WINDOWS- void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)- pure ExitSuccess+ void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)+ pure ExitSuccess #else- r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)- case r' of- VRight _ -> pure ExitSuccess- VLeft e -> do- runLogger $ logError $ T.pack $ prettyShow e- pure $ ExitFailure 28+ r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)+ case r' of+ VRight _ -> pure ExitSuccess+ VLeft e -> do+ runLogger $ logError $ T.pack $ prettyShow e+ pure $ ExitFailure 28 #endif- VLeft e -> do- runLogger $ logError $ T.pack $ prettyShow e- pure $ ExitFailure 27+ VLeft e -> do+ runLogger $ logError $ T.pack $ prettyShow e+ pure $ ExitFailure 27+ where+ isToolTag :: ToolVersion -> Bool isToolTag (ToolTag _) = True isToolTag _ = False -- TODO: doesn't work for cross- addToolsToDir tmp- | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do- forM_ runGHCVer $ \ver -> do+ resolveToolchainFull :: ( MonadFail m+ , MonadThrow m+ , MonadIO m+ , MonadCatch m+ )+ => Excepts+ '[ TagNotFound+ , NextVerNotFound+ , NoToolVersionSet+ ] (ResourceT (ReaderT AppState m)) Toolchain+ resolveToolchainFull = do+ ghcVer <- forM runGHCVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) GHC- installTool GHC v- setTool GHC v tmp- forM_ runCabalVer $ \ver -> do+ pure v+ cabalVer <- forM runCabalVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Cabal- installTool Cabal v- setTool Cabal v tmp- forM_ runHLSVer $ \ver -> do+ pure v+ hlsVer <- forM runHLSVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) HLS- installTool HLS v- setTool HLS v tmp- forM_ runStackVer $ \ver -> do+ pure v+ stackVer <- forM runStackVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Stack- installTool Stack v- setTool Stack v tmp- | otherwise = runLeanRUN leanAppstate $ do- case runGHCVer of- Just (ToolVersion v) ->- setTool GHC v tmp- Nothing -> pure ()+ pure v+ pure Toolchain{..}++ resolveToolchain = do+ ghcVer <- case runGHCVer of+ Just (ToolVersion v) -> pure $ Just v+ Nothing -> pure Nothing _ -> fail "Internal error"- case runCabalVer of- Just (ToolVersion v) ->- setTool Cabal v tmp- Nothing -> pure ()+ cabalVer <- case runCabalVer of+ Just (ToolVersion v) -> pure $ Just v+ Nothing -> pure Nothing _ -> fail "Internal error"- case runHLSVer of- Just (ToolVersion v) ->- setTool HLS v tmp- Nothing -> pure ()+ hlsVer <- case runHLSVer of+ Just (ToolVersion v) -> pure $ Just v+ Nothing -> pure Nothing _ -> fail "Internal error"- case runStackVer of- Just (ToolVersion v) ->- setTool Stack v tmp- Nothing -> pure ()+ stackVer <- case runStackVer of+ Just (ToolVersion v) -> pure $ Just v+ Nothing -> pure Nothing _ -> fail "Internal error"+ pure Toolchain{..} - installTool tool v = do- isInstalled <- checkIfToolInstalled' tool v- case tool of- GHC -> do- unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin- (_tvVersion v)- Nothing- False- Cabal -> do- unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin- (_tvVersion v)- Nothing- False- Stack -> do- unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin- (_tvVersion v)- Nothing- False- HLS -> do- unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin- (_tvVersion v)- Nothing- False- GHCup -> pure ()+ installToolChainFull :: ( MonadFail m+ , MonadThrow m+ , MonadIO m+ , MonadCatch m+ )+ => Toolchain+ -> FilePath+ -> Excepts+ '[ TagNotFound+ , NextVerNotFound+ , NoToolVersionSet+ , UnknownArchive+ , TarDirDoesNotExist+ , ProcessError+ , NotInstalled+ , NoDownload+ , GPGError+ , DownloadFailed+ , DirNotEmpty+ , DigestError+ , BuildFailed+ , ArchiveResult+ , AlreadyInstalled+ , FileAlreadyExistsError+ , CopyError+ ] (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)+ Nothing+ False+ setTool GHC v tmp+ Just (Cabal, v) -> do+ unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin+ (_tvVersion v)+ Nothing+ False+ setTool Cabal v tmp+ Just (Stack, v) -> do+ unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin+ (_tvVersion v)+ Nothing+ False+ setTool Stack v tmp+ Just (HLS, v) -> do+ unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin+ (_tvVersion v)+ Nothing+ False+ setTool HLS v tmp+ _ -> pure () + installToolChain :: ( MonadFail m+ , MonadThrow m+ , MonadIO m+ , MonadCatch m+ )+ => Toolchain+ -> 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 ()+ setTool tool v tmp = case tool of GHC -> do@@ -324,7 +411,7 @@ if legacy then do -- TODO: factor this out- (Just hlsWrapper) <- hlsWrapperBinary 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 </>))@@ -346,3 +433,31 @@ envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath liftIO $ setEnv pathVar newPath return envWithNewPath++ predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =+ liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))+ predictableTmpDir Toolchain{..} = do+ tmp <- getTemporaryDirectory+ pure $ tmp+ </> ("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+ )+ )++++ -------------------------+ --[ Other local types ]--+ -------------------------++++data Toolchain = Toolchain+ { ghcVer :: Maybe GHCTargetVersion+ , cabalVer :: Maybe GHCTargetVersion+ , hlsVer :: Maybe GHCTargetVersion+ , stackVer :: Maybe GHCTargetVersion+ }
app/ghcup/GHCup/OptParse/ToolRequirements.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE QuasiQuotes #-} module GHCup.OptParse.ToolRequirements where @@ -11,6 +12,7 @@ import GHCup.Errors import GHCup.Types import GHCup.Utils.Logger+import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -34,8 +36,43 @@ + ---------------+ --[ Options ]--+ --------------- +data ToolReqOpts = ToolReqOpts+ { tlrRaw :: Bool+ }+++++ ---------------+ --[ Parsers ]--+ ---------------++ +toolReqP :: Parser ToolReqOpts+toolReqP =+ ToolReqOpts+ <$> switch (short 'r' <> long "raw-format" <> help "machine-parsable format")+++++ --------------+ --[ Footer ]--+ --------------+++toolReqFooter :: String+toolReqFooter = [s|Discussion:+ Print tool requirements on the current platform.+ If you want to pass this to your package manage, use '--raw-format'.|]+++ --------------------------- --[ Effect interpreters ]-- ---------------------------@@ -66,14 +103,17 @@ , MonadFail m , Alternative m )- => (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))+ => ToolReqOpts+ -> (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ())) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode-toolRequirements runAppState runLogger = runToolRequirements runAppState (do+toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements runAppState (do GHCupInfo { .. } <- lift getGHCupInfo platform' <- liftE getPlatform- req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements- liftIO $ T.hPutStr stdout (prettyRequirements req)+ req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements+ if tlrRaw+ then liftIO $ T.hPutStr stdout (rawRequirements req)+ else liftIO $ T.hPutStr stdout (prettyRequirements req) ) >>= \case VRight _ -> pure ExitSuccess
app/ghcup/GHCup/OptParse/Upgrade.hs view
@@ -72,6 +72,7 @@ str (short 't' <> long "target" <> metavar "TARGET_DIR" <> help "Absolute filepath to write ghcup into"+ <> completer (bashCompleter "file") ) ) <|> pure UpgradeGHCupDir
app/ghcup/Main.hs view
@@ -82,7 +82,7 @@ keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings- urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource+ urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg in (Settings {..}, keyBindings)@@ -228,14 +228,16 @@ Nuke -> pure () Whereis _ _ -> pure () DInfo -> pure ()- ToolRequirements -> pure ()+ ToolRequirements _ -> pure () ChangeLog _ -> pure () UnSet _ -> pure () #if defined(BRICK) Interactive -> pure () #endif -- check for new tools- _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case+ _+ | Just False <- optVerbose -> pure ()+ | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do newTools <- lift checkForUpdates forM_ newTools $ \newTool@(t, l) -> do@@ -308,12 +310,12 @@ #ifndef DISABLE_UPGRADE Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger #endif- ToolRequirements -> toolRequirements runAppState runLogger+ ToolRequirements topts -> toolRequirements topts runAppState runLogger ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger Nuke -> nuke appState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger- Run runCommand -> run runCommand runAppState leanAppstate runLogger+ Run runCommand -> run runCommand appState leanAppstate runLogger case res of ExitSuccess -> pure ()
data/config.yaml view
@@ -48,12 +48,16 @@ ## Example 1: Read download info from this location instead ## Accepts file/http/https scheme+ ## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in+ ## which case they are merged right-biased (overwriting duplicate versions). # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml" - ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions+ ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.+ ## Can also be an array of 'Either GHCupInfo URL', also see Example 3. # AddSource: # Left:- # toolRequirements: {} # this is ignored+ # globalTools: {}+ # toolRequirements: {} # ghcupDownloads: # GHC: # 9.10.2:@@ -66,6 +70,8 @@ # dlSubdir: ghc-7.10.3 # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5 - ## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions+ ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate+ ## versions). # AddSource:- # Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"+ # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"+ # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
ghcup.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup-version: 0.1.17.5+version: 0.1.17.6 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020@@ -50,7 +50,7 @@ flag disable-upgrade description:- Build the brick powered tui (ghcup tui). This is disabled on windows.+ Disable upgrade functionality. This is mainly to support brew packagers. default: False manual: True@@ -121,7 +121,7 @@ , haskus-utils-variant ^>=3.2.1 , libarchive ^>=3.0.3.0 , lzma-static ^>=5.2.5.3- , megaparsec >=8.0.0 && <9.1+ , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 , optics ^>=0.4 , os-release ^>=1.0.0@@ -236,19 +236,23 @@ , ghcup , haskus-utils-variant ^>=3.2.1 , libarchive ^>=3.0.3.0- , megaparsec >=8.0.0 && <9.1+ , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2- , optparse-applicative >=0.15.1.0 && <0.17+ , optparse-applicative >=0.15.1.0 && <0.18 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0+ , process ^>=1.6.11.0 , resourcet ^>=1.2.2 , safe ^>=0.3.18 , safe-exceptions ^>=0.1- , temporary ^>=1.3+ , tagsoup ^>=0.14 , template-haskell >=2.7 && <2.18+ , temporary ^>=1.3 , text ^>=1.2.4.0+ , unordered-containers ^>=0.2 , uri-bytestring ^>=0.3.2.2 , utf8-string ^>=1.0+ , vector ^>=0.12 , versions >=4.0.1 && <5.1 , yaml-streamly ^>=0.12.0 @@ -262,23 +266,22 @@ , brick ^>=0.64 , transformers ^>=0.5 , unix ^>=2.7- , vector ^>=0.12 , vty >=5.28.2 && <5.34 if os(windows) cpp-options: -DIS_WINDOWS+ else- build-depends:- , unix ^>=2.7+ build-depends: unix ^>=2.7 if flag(no-exe) buildable: False - if (flag(disable-upgrade))- cpp-options: -DDISABLE_UPGRADE+ if flag(disable-upgrade)+ cpp-options: -DDISABLE_UPGRADE+ else- other-modules:- GHCup.OptParse.Upgrade+ other-modules: GHCup.OptParse.Upgrade test-suite ghcup-test type: exitcode-stdio-1.0@@ -307,9 +310,9 @@ , base >=4.12 && <5 , bytestring ^>=0.10 , containers ^>=0.6- , generic-arbitrary ^>=0.1.0+ , generic-arbitrary >=0.1.0 && <0.3 , ghcup- , hspec ^>=2.7.10+ , hspec >=2.7.10 && <2.10 , hspec-golden-aeson ^>=0.9 , QuickCheck ^>=2.14.1 , quickcheck-arbitrary-adt ^>=0.3.1.0
lib/GHCup.hs view
@@ -468,10 +468,6 @@ Nothing -> do -- regular install liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall - -- create symlink if this is the latest version for regular installs- cVers <- lift $ fmap rights getInstalledCabals- let lInstCabal = headMay . reverse . sort $ cVers- when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution.Symbol installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)@@ -626,7 +622,6 @@ liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver liftE $ setHLS ver SetHLS_XYZ Nothing - liftE $ installHLSPostInst isoFilepath ver isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist -> IO Bool@@ -696,20 +691,7 @@ lift $ chmod_755 destWrapperPath -installHLSPostInst :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadCatch m, MonadMask m, MonadFail m, MonadUnliftIO m)- => Maybe FilePath- -> Version- -> Excepts '[NotInstalled] m ()-installHLSPostInst isoFilepath ver = - case isoFilepath of- Just _ -> pure ()- Nothing -> do- -- create symlink if this is the latest version in a regular install- hlsVers <- lift $ fmap rights getInstalledHLSs- let lInstHLS = headMay . reverse . sort $ hlsVers- when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly Nothing - -- | Installs hls binaries @haskell-language-server-\<ghcver\>@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m@@ -916,8 +898,6 @@ liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True ) - liftE $ installHLSPostInst isolateDir installVer- pure installVer @@ -1033,11 +1013,6 @@ liftE $ installStackUnpacked workdir isoDir Nothing forceInstall Nothing -> do -- regular install liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall-- -- create symlink if this is the latest version and a regular install- sVers <- lift $ fmap rights getInstalledStacks- let lInstStack = headMay . reverse . sort $ sVers- when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver -- | Install an unpacked stack distribution.
lib/GHCup/Download.hs view
@@ -121,28 +121,25 @@ Settings { urlSource } <- lift getSettings case urlSource of GHCupURL -> liftE $ getBase ghcupURL- (OwnSource url) -> liftE $ getBase url+ (OwnSource exts) -> do+ ext <- liftE $ mapM (either pure getBase) exts+ mergeGhcupInfo ext (OwnSpec av) -> pure av- (AddSource (Left ext)) -> do- base <- liftE $ getBase ghcupURL- pure (mergeGhcupInfo base ext)- (AddSource (Right uri)) -> do+ (AddSource exts) -> do base <- liftE $ getBase ghcupURL- ext <- liftE $ getBase uri- pure (mergeGhcupInfo base ext)-- where+ ext <- liftE $ mapM (either pure getBase) exts+ mergeGhcupInfo (base:ext) - mergeGhcupInfo :: GHCupInfo -- ^ base to merge with- -> GHCupInfo -- ^ extension overwriting the base- -> GHCupInfo- mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =- let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of- Just a' -> M.union a' a- Nothing -> a- ) base- newGlobalTools = M.union base2 ext2- in GHCupInfo tr newDownloads newGlobalTools+ where+ mergeGhcupInfo :: MonadFail m+ => [GHCupInfo]+ -> m GHCupInfo+ mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"+ mergeGhcupInfo xs@(GHCupInfo{}: _) =+ let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)+ newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs)+ newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)+ in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
lib/GHCup/Requirements.hs view
@@ -67,3 +67,9 @@ else "" n = if not . T.null $ _notes then "\n Note: " <> _notes else "" in "System requirements " <> d <> n++rawRequirements :: Requirements -> T.Text+rawRequirements Requirements {..} =+ if not . null $ _distroPKGs+ then T.intercalate " " _distroPKGs+ else ""
lib/GHCup/Types.hs view
@@ -286,9 +286,9 @@ -- | Where to fetch GHCupDownloads from. data URLSource = GHCupURL- | OwnSource URI+ | OwnSource [Either GHCupInfo URI] -- ^ complete source list | OwnSpec GHCupInfo- | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL+ | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL deriving (GHC.Generic, Show) instance NFData URLSource
lib/GHCup/Types/JSON.hs view
@@ -79,6 +79,38 @@ instance ToJSON URI where toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' +instance FromJSON URLSource where+ parseJSON v =+ parseGHCupURL v+ <|> parseOwnSourceLegacy v+ <|> parseOwnSourceNew1 v+ <|> parseOwnSourceNew2 v+ <|> parseOwnSpec v+ <|> legacyParseAddSource v+ <|> newParseAddSource v+ where+ parseOwnSourceLegacy = withObject "URLSource" $ \o -> do+ r :: URI <- o .: "OwnSource"+ pure (OwnSource [Right r])+ parseOwnSourceNew1 = withObject "URLSource" $ \o -> do+ r :: [URI] <- o .: "OwnSource"+ pure (OwnSource (fmap Right r))+ parseOwnSourceNew2 = withObject "URLSource" $ \o -> do+ r :: [Either GHCupInfo URI] <- o .: "OwnSource"+ pure (OwnSource r)+ parseOwnSpec = withObject "URLSource" $ \o -> do+ r :: GHCupInfo <- o .: "OwnSpec"+ pure (OwnSpec r)+ parseGHCupURL = withObject "URLSource" $ \o -> do+ _ :: [Value] <- o .: "GHCupURL"+ pure GHCupURL+ legacyParseAddSource = withObject "URLSource" $ \o -> do+ r :: Either GHCupInfo URI <- o .: "AddSource"+ pure (AddSource [r])+ newParseAddSource = withObject "URLSource" $ \o -> do+ r :: [Either GHCupInfo URI] <- o .: "AddSource"+ pure (AddSource r)+ instance FromJSON URI where parseJSON = withText "URL" $ \t -> case parseURI strictURIParserOptions (encodeUtf8 t) of@@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo-deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource+deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
lib/GHCup/Utils/Dirs.hs view
@@ -339,13 +339,15 @@ relativeSymlink :: FilePath -- ^ the path in which to create the symlink -> FilePath -- ^ the symlink destination -> FilePath-relativeSymlink p1 p2 =- let d1 = splitDirectories p1- d2 = splitDirectories p2- common = takeWhile (\(x, y) -> x == y) $ zip d1 d2- cPrefix = drop (length common) d1- in joinPath (replicate (length cPrefix) "..")- <> joinPath ([pathSeparator] : drop (length common) d2)+relativeSymlink p1 p2+ | isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks+ | otherwise =+ let d1 = splitDirectories p1+ d2 = splitDirectories p2+ common = takeWhile (\(x, y) -> x == y) $ zip d1 d2+ cPrefix = drop (length common) d1+ in joinPath (replicate (length cPrefix) "..")+ <> joinPath ([pathSeparator] : drop (length common) d2) cleanupTrash :: ( MonadIO m