Compare commits

..

16 Commits

16 changed files with 670 additions and 139 deletions

View File

@@ -37,9 +37,6 @@ binary=$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'c
ver=$("${binary}" --numeric-version) ver=$("${binary}" --numeric-version)
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
strip "${binary}" strip "${binary}"
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/318
codesign -s - -o linker-signed -i ghcup -v "${binary}"
:
else else
strip -s "${binary}" strip -s "${binary}"
fi fi

View File

@@ -1,5 +1,11 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.17.6 -- ????-??-??
* 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)
## 0.1.17.5 -- 2022-02-26 ## 0.1.17.5 -- 2022-02-26
* Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137) * Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137)

View File

@@ -124,6 +124,7 @@ opts =
<> metavar "URL" <> metavar "URL"
<> help "Alternative ghcup download info url" <> help "Alternative ghcup download info url"
<> internal <> internal
<> completer fileUri
) )
) )
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)")) <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
@@ -134,6 +135,7 @@ opts =
<> help <> help
"Keep build directories? (default: errors)" "Keep build directories? (default: errors)"
<> hidden <> hidden
<> completer (listCompleter ["always", "errors", "never"])
)) ))
<*> optional (option <*> optional (option
(eitherReader downloaderParser) (eitherReader downloaderParser)
@@ -142,10 +144,12 @@ opts =
<> metavar "<internal|curl|wget>" <> metavar "<internal|curl|wget>"
<> help <> help
"Downloader to use (default: internal)" "Downloader to use (default: internal)"
<> completer (listCompleter ["internal", "curl", "wget"])
#else #else
<> metavar "<curl|wget>" <> metavar "<curl|wget>"
<> help <> help
"Downloader to use (default: curl)" "Downloader to use (default: curl)"
<> completer (listCompleter ["curl", "wget"])
#endif #endif
<> hidden <> hidden
)) ))
@@ -156,6 +160,7 @@ opts =
<> metavar "<strict|lax|none>" <> metavar "<strict|lax|none>"
<> help <> help
"GPG verification (default: none)" "GPG verification (default: none)"
<> completer (listCompleter ["strict", "lax", "none"])
)) ))
<*> com <*> com
where where

View File

@@ -76,6 +76,7 @@ changelogP =
) )
(short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)" "Open changelog for given tool (default: ghc)"
<> completer toolCompleter
) )
) )
<*> optional (toolVersionArgument Nothing Nothing) <*> optional (toolVersionArgument Nothing Nothing)

View File

@@ -3,6 +3,8 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NumericUnderscores #-}
module GHCup.OptParse.Common where module GHCup.OptParse.Common where
@@ -14,36 +16,55 @@ import GHCup.Platform
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.MegaParsec import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import Control.DeepSeq
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception.Safe import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
import Control.Monad.Reader 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.Bifunctor
import Data.Char import Data.Char
import Data.Either import Data.Either
import Data.Functor import Data.Functor
import Data.List ( nub, sort, sortBy ) import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix )
import Data.Maybe import Data.Maybe
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions hiding ( str ) import Data.Versions hiding ( str )
import Data.Void import Data.Void
import qualified Data.Vector as V
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import Safe import Safe
import System.Directory
import System.Process ( readProcess )
import System.FilePath import System.FilePath
import Text.HTML.TagSoup hiding ( Tag )
import URI.ByteString import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified System.FilePath.Posix as FP
import GHCup.Version import GHCup.Version
import Control.Exception (evaluate)
------------- -------------
@@ -277,6 +298,126 @@ gpgParser s' | t == T.pack "strict" = Right GPGStrict
--[ Completers ]-- --[ 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 -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs dirs' <- liftIO getAllDirs
@@ -334,6 +475,150 @@ versionCompleter criteria tool = listIOCompleter $ do
return $ T.unpack . prettyVer . lVer <$> installedVersions 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
----------------- -----------------

View File

@@ -165,6 +165,7 @@ ghcCompileOpts =
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile" "The tool version to compile"
<> (completer $ versionCompleter Nothing GHC)
) )
) <|> ) <|>
(Right <$> (GitBranch <$> option (Right <$> (GitBranch <$> option
@@ -172,7 +173,10 @@ ghcCompileOpts =
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from" "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 <*> option
(eitherReader (eitherReader
@@ -185,12 +189,14 @@ ghcCompileOpts =
<> metavar "BOOTSTRAP_GHC" <> metavar "BOOTSTRAP_GHC"
<> help <> help
"The GHC version (or full path) to bootstrap with (must be installed)" "The GHC version (or full path) to bootstrap with (must be installed)"
<> (completer $ versionCompleter Nothing GHC)
) )
<*> optional <*> optional
(option (option
(eitherReader (readEither @Int)) (eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help (short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make" "How many jobs to use for make"
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
) )
) )
<*> optional <*> optional
@@ -198,6 +204,7 @@ ghcCompileOpts =
str str
(short 'c' <> long "config" <> metavar "CONFIG" <> help (short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file" "Absolute path to build config file"
<> completer (bashCompleter "file")
) )
) )
<*> (optional <*> (optional
@@ -206,6 +213,7 @@ ghcCompileOpts =
(eitherReader uriParser) (eitherReader uriParser)
(long "patch" <> metavar "PATCH_URI" <> help (long "patch" <> metavar "PATCH_URI" <> help
"URI to a patch (https/http/file)" "URI to a patch (https/http/file)"
<> completer fileUri
) )
) )
<|> <|>
@@ -213,6 +221,7 @@ ghcCompileOpts =
str str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help (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)" "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")
) )
) )
) )
@@ -238,6 +247,7 @@ ghcCompileOpts =
) )
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help (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'" "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 <*> optional
@@ -257,6 +267,7 @@ ghcCompileOpts =
<> long "isolate" <> long "isolate"
<> metavar "DIR" <> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made" <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
<> completer (bashCompleter "directory")
) )
) )
@@ -269,6 +280,7 @@ hlsCompileOpts =
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile" "The tool version to compile"
<> (completer $ versionCompleter Nothing HLS)
) )
) <|> ) <|>
(Right <$> (GitBranch <$> option (Right <$> (GitBranch <$> option
@@ -276,13 +288,16 @@ hlsCompileOpts =
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from" "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 <*> optional
(option (option
(eitherReader (readEither @Int)) (eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help (short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make" "How many jobs to use for make"
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
) )
) )
<*> flag <*> flag
@@ -298,6 +313,7 @@ hlsCompileOpts =
) )
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help (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'" "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 <*> optional
@@ -307,6 +323,7 @@ hlsCompileOpts =
<> long "isolate" <> long "isolate"
<> metavar "DIR" <> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made" <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
<> completer (bashCompleter "directory")
) )
) )
<*> optional <*> optional
@@ -314,6 +331,7 @@ hlsCompileOpts =
((fmap Right $ eitherReader uriParser) <|> (fmap Left str)) ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
(long "cabal-project" <> metavar "CABAL_PROJECT" <> help (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." "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 <*> optional
@@ -321,6 +339,7 @@ hlsCompileOpts =
(eitherReader uriParser) (eitherReader uriParser)
(long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help (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." "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
<> completer fileUri
) )
) )
<*> (optional <*> (optional
@@ -329,6 +348,7 @@ hlsCompileOpts =
(eitherReader uriParser) (eitherReader uriParser)
(long "patch" <> metavar "PATCH_URI" <> help (long "patch" <> metavar "PATCH_URI" <> help
"URI to a patch (https/http/file)" "URI to a patch (https/http/file)"
<> completer fileUri
) )
) )
<|> <|>
@@ -336,6 +356,7 @@ hlsCompileOpts =
str str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
<> completer (bashCompleter "directory")
) )
) )
) )

View File

@@ -6,6 +6,7 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Install where module GHCup.OptParse.Install where
@@ -189,6 +190,7 @@ installOpts tool =
(eitherReader uriParser) (eitherReader uriParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist" "Install the specified version from this bindist"
<> completer (toolDlCompleter (fromMaybe GHC tool))
) )
) )
<*> (Just <$> toolVersionArgument Nothing tool) <*> (Just <$> toolVersionArgument Nothing tool)
@@ -208,6 +210,7 @@ installOpts tool =
<> long "isolate" <> long "isolate"
<> metavar "DIR" <> metavar "DIR"
<> help "install in an isolated dir instead of the default one" <> help "install in an isolated dir instead of the default one"
<> completer (bashCompleter "directory")
) )
) )
<*> switch <*> switch
@@ -253,6 +256,48 @@ type InstallEffects = '[ AlreadyInstalled
, NoToolVersionSet , NoToolVersionSet
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , 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)
] ]
@@ -418,20 +463,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin void $ liftE $ sequenceE (installCabalBin
(_tvVersion v) v
isolateDir isolateDir
forceInstall forceInstall
) $ when instSet $ void $ setCabal v
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist void $ liftE $ sequenceE (installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) v
isolateDir isolateDir
forceInstall forceInstall
) $ when instSet $ void $ setCabal v
pure vi pure vi
) )
>>= \case >>= \case
@@ -448,6 +495,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 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 VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
@@ -459,21 +514,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin void $ liftE $ sequenceE (installHLSBin
(_tvVersion v) v
isolateDir isolateDir
forceInstall forceInstall
) $ when instSet $ void $ setHLS v SetHLSOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ 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 -- TODO: support legacy
liftE $ installHLSBindist void $ liftE $ sequenceE (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
(_tvVersion v) v
isolateDir isolateDir
forceInstall forceInstall
) $ when instSet $ void $ setHLS v SetHLSOnly Nothing
pure vi pure vi
) )
>>= \case >>= \case
@@ -494,6 +551,18 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 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 VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
@@ -505,20 +574,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin void $ liftE $ sequenceE (installStackBin
(_tvVersion v) v
isolateDir isolateDir
forceInstall forceInstall
) $ when instSet $ void $ setStack v
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist void $ liftE $ sequenceE (installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) v
isolateDir isolateDir
forceInstall forceInstall
) $ when instSet $ void $ setStack v
pure vi pure vi
) )
>>= \case >>= \case
@@ -535,6 +606,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 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
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e

View File

@@ -69,6 +69,7 @@ listOpts =
(eitherReader toolParser) (eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
"Tool to list versions for. Default is all" "Tool to list versions for. Default is all"
<> completer (toolCompleter)
) )
) )
<*> optional <*> optional
@@ -78,6 +79,7 @@ listOpts =
<> long "show-criteria" <> long "show-criteria"
<> metavar "<installed|set|available>" <> metavar "<installed|set|available>"
<> help "Show only installed/set/available tool versions" <> help "Show only installed/set/available tool versions"
<> completer (listCompleter ["installed", "set", "available"])
) )
) )
<*> switch <*> switch

View File

@@ -83,7 +83,7 @@ prefetchP = subparser
(PrefetchGHC (PrefetchGHC
<$> (PrefetchGHCOptions <$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> optional (toolVersionArgument Nothing (Just GHC)) ) <*> optional (toolVersionArgument Nothing (Just GHC)) )
( progDesc "Download GHC assets for installation") ( progDesc "Download GHC assets for installation")
) )
@@ -92,7 +92,7 @@ prefetchP = subparser
"cabal" "cabal"
(info (info
(PrefetchCabal (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 )) <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation") ( progDesc "Download cabal assets for installation")
) )
@@ -101,7 +101,7 @@ prefetchP = subparser
"hls" "hls"
(info (info
(PrefetchHLS (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 )) <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation") ( progDesc "Download HLS assets for installation")
) )
@@ -110,7 +110,7 @@ prefetchP = subparser
"stack" "stack"
(info (info
(PrefetchStack (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 )) <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation") ( progDesc "Download stack assets for installation")
) )

View File

@@ -35,7 +35,6 @@ import Prelude hiding ( appendFile )
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Environment import System.Environment
import System.IO.Temp
import System.Exit import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -72,6 +71,7 @@ data RunOptions = RunOptions
--------------- ---------------
runOpts :: Parser RunOptions runOpts :: Parser RunOptions
runOpts = runOpts =
RunOptions RunOptions
@@ -82,22 +82,34 @@ runOpts =
<*> optional <*> optional
(option (option
(eitherReader toolVersionEither) (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 <*> optional
(option (option
(eitherReader toolVersionEither) (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 <*> optional
(option (option
(eitherReader toolVersionEither) (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 <*> optional
(option (option
(eitherReader toolVersionEither) (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 <*> optional
(option (option
@@ -106,6 +118,7 @@ runOpts =
<> long "bindir" <> long "bindir"
<> metavar "DIR" <> metavar "DIR"
<> help "directory where to create the tool symlinks (default: newly created system temp 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.")) <*> 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."))
@@ -203,16 +216,20 @@ run :: forall m.
-> LeanAppState -> LeanAppState
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
run RunOptions{..} runAppState leanAppstate runLogger = do run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
toolchain <- Excepts resolveToolchain
tmp <- case runBinDir of tmp <- case runBinDir of
Just bdir -> do Just bindir -> do
liftIO $ createDirRecursive' bdir liftIO $ createDirRecursive' bindir
liftIO $ canonicalizePath bdir liftIO $ canonicalizePath bindir
Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup") Nothing -> do
r <- do d <- liftIO $ predictableTmpDir toolchain
addToolsToDir tmp liftIO $ createDirRecursive' d
case r of liftIO $ canonicalizePath d
VRight _ -> do Excepts $ installToolChain toolchain tmp
pure tmp
) >>= \case
VRight tmp -> do
case runCOMMAND of case runCOMMAND of
[] -> do [] -> do
liftIO $ putStr tmp liftIO $ putStr tmp
@@ -239,70 +256,78 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
isToolTag _ = False isToolTag _ = False
-- TODO: doesn't work for cross -- TODO: doesn't work for cross
addToolsToDir tmp resolveToolchain
| or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
forM_ runGHCVer $ \ver -> do ghcVer <- forM runGHCVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) GHC (v, _) <- liftE $ fromVersion (Just ver) GHC
installTool GHC v pure v
setTool GHC v tmp cabalVer <- forM runCabalVer $ \ver -> do
forM_ runCabalVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Cabal (v, _) <- liftE $ fromVersion (Just ver) Cabal
installTool Cabal v pure v
setTool Cabal v tmp hlsVer <- forM runHLSVer $ \ver -> do
forM_ runHLSVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) HLS (v, _) <- liftE $ fromVersion (Just ver) HLS
installTool HLS v pure v
setTool HLS v tmp stackVer <- forM runStackVer $ \ver -> do
forM_ runStackVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Stack (v, _) <- liftE $ fromVersion (Just ver) Stack
installTool Stack v pure v
setTool Stack v tmp pure Toolchain{..}
| otherwise = runLeanRUN leanAppstate $ do | otherwise = runLeanRUN leanAppstate $ do
case runGHCVer of ghcVer <- case runGHCVer of
Just (ToolVersion v) -> Just (ToolVersion v) -> pure $ Just v
setTool GHC v tmp Nothing -> pure Nothing
Nothing -> pure ()
_ -> fail "Internal error" _ -> fail "Internal error"
case runCabalVer of cabalVer <- case runCabalVer of
Just (ToolVersion v) -> Just (ToolVersion v) -> pure $ Just v
setTool Cabal v tmp Nothing -> pure Nothing
Nothing -> pure ()
_ -> fail "Internal error" _ -> fail "Internal error"
case runHLSVer of hlsVer <- case runHLSVer of
Just (ToolVersion v) -> Just (ToolVersion v) -> pure $ Just v
setTool HLS v tmp Nothing -> pure Nothing
Nothing -> pure ()
_ -> fail "Internal error" _ -> fail "Internal error"
case runStackVer of stackVer <- case runStackVer of
Just (ToolVersion v) -> Just (ToolVersion v) -> pure $ Just v
setTool Stack v tmp Nothing -> pure Nothing
Nothing -> pure ()
_ -> fail "Internal error" _ -> fail "Internal error"
pure Toolchain{..}
installTool tool v = do installToolChain Toolchain{..} tmp
isInstalled <- checkIfToolInstalled' tool v | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
case tool of forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
GHC -> do isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin case mt of
(_tvVersion v) Just (GHC, v) -> do
Nothing unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
False (_tvVersion v)
Cabal -> do Nothing
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin False
(_tvVersion v) setTool GHC v tmp
Nothing Just (Cabal, v) -> do
False unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
Stack -> do (_tvVersion v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin Nothing
(_tvVersion v) False
Nothing setTool Cabal v tmp
False Just (Stack, v) -> do
HLS -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin (_tvVersion v)
(_tvVersion v) Nothing
Nothing False
False setTool Stack v tmp
GHCup -> pure () Just (HLS, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
(_tvVersion v)
Nothing
False
setTool HLS v tmp
_ -> pure ()
| otherwise = runLeanRUN leanAppstate $ 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 = setTool tool v tmp =
case tool of case tool of
@@ -324,7 +349,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
if legacy if legacy
then do then do
-- TODO: factor this out -- TODO: factor this out
(Just hlsWrapper) <- hlsWrapperBinary v' hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v' !? (NotInstalled HLS (mkTVer v'))
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper) cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw) lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>)) hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
@@ -346,3 +371,30 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
liftIO $ setEnv pathVar newPath liftIO $ setEnv pathVar newPath
return envWithNewPath return envWithNewPath
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =
liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))
predictableTmpDir Toolchain{..} = do
tmp <- getTemporaryDirectory
pure $ tmp
</> ("ghcup"
<> 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
}

View File

@@ -72,6 +72,7 @@ upgradeOptsP =
str str
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into" "Absolute filepath to write ghcup into"
<> completer (bashCompleter "file")
) )
) )
<|> pure UpgradeGHCupDir <|> pure UpgradeGHCupDir

View File

@@ -1,5 +1,8 @@
:root { :root {
--theme-purple: #5E5184; --theme-purple: #5E5184;
--theme-purple-dark: rgba(69, 59, 97, 0.5);
--ukraine-top: #0057B8;
--ukraine-bottom: #FFD700;
--link-pink: #9E358F; --link-pink: #9E358F;
} }
@@ -108,12 +111,12 @@ body.homepage>div.container div.col-md-9 {
.bg-primary { .bg-primary {
background-image: none; background-image: none;
background-color: var(--theme-purple) !important; background-color: var(--ukraine-top) !important;
} }
body .bg-primary { body .bg-primary {
background-image: none; background-image: none;
background-color: var(--theme-purple); background-color: var(--ukraine-top);
border: 0px; border: 0px;
} }
@@ -125,8 +128,8 @@ body .btn-primary {
.navbar.fixed-top { .navbar.fixed-top {
background-image: none; background-image: none;
background-color: var(--theme-purple); background-color: var(--ukraine-top);
border-bottom: 5px solid rgba(69, 59, 97, 0.5); border-bottom: 40px solid var(--ukraine-bottom);
padding: 0px; padding: 0px;
} }

View File

@@ -50,10 +50,90 @@ On windows, double-click on the `Uninstall Haskell.ps1` PowerShell script on you
GHCup supports the following tools, which are also known as the **Haskell Toolchain**: GHCup supports the following tools, which are also known as the **Haskell Toolchain**:
1. [GHC](https://www.haskell.org/ghc/) <details>
2. [cabal-install](https://cabal.readthedocs.io/en/stable/) <summary>Show all supported <a href='https://www.haskell.org/ghc/'>GHC</a> versions</summary>
3. [haskell-language-server](https://haskell-language-server.readthedocs.io/en/stable/)
4. [stack](https://docs.haskellstack.org/en/stable/README/) <table>
<thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
<tbody>
<tr><td>7.10.3</td><td>base-4.8.2.0</td></tr>
<tr><td>8.0.2</td><td>base-4.9.1.0</td></tr>
<tr><td>8.2.2</td><td>base-4.10.1.0</td></tr>
<tr><td>8.4.1</td><td>base-4.11.0.0</td></tr>
<tr><td>8.4.2</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.3</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.4</td><td>base-4.11.1.0</td></tr>
<tr><td>8.6.1</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.2</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.3</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.4</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.5</td><td>base-4.12.0.0</td></tr>
<tr><td>8.8.1</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.2</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.3</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.4</td><td>base-4.13.0.0</td></tr>
<tr><td>8.10.1</td><td>base-4.14.0.0</td></tr>
<tr><td>8.10.2</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.3</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.4</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.5</td><td>base-4.14.2.0</td></tr>
<tr><td>8.10.6</td><td>base-4.14.3.0</td></tr>
<tr><td>8.10.7</td><td><span style="color:green">recommended</span>, base-4.14.3.0</td></tr>
<tr><td>9.0.1</td><td>base-4.15.0.0</td></tr>
<tr><td>9.0.2</td><td>base-4.15.1.0</td></tr>
<tr><td>9.2.1</td><td>base-4.16.0.0</td></tr>
<tr><td>9.2.2</td><td><span style="color:blue">latest</span>, base-4.16.1.0</td></tr>
</tbody>
</table>
</details>
<details>
<summary>Show all supported <a href='https://cabal.readthedocs.io/en/stable/'>cabal-install</a> versions</summary>
<table>
<thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead>
<tbody>
<tr><td>2.4.1.0</td><td></td></tr>
<tr><td>3.0.0.0</td><td></td></tr>
<tr><td>3.2.0.0</td><td></td></tr>
<tr><td>3.4.0.0</td><td></td></tr>
<tr><td>3.4.1.0</td><td></td></tr>
<tr><td>3.6.0.0</td><td></td></tr>
<tr><td>3.6.2.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
</tbody>
</table>
</details>
<details>
<summary>Show all supported <a href='https://haskell-language-server.readthedocs.io/en/stable/'>HLS</a> versions</summary>
<table>
<thead><tr><th>HLS Version</th><th>Tags</th></tr></thead>
<tbody>
<tr><td>1.1.0</td><td></td></tr>
<tr><td>1.2.0</td><td></td></tr>
<tr><td>1.3.0</td><td></td></tr>
<tr><td>1.4.0</td><td></td></tr>
<tr><td>1.5.0</td><td></td></tr>
<tr><td>1.5.1</td><td></td></tr>
<tr><td>1.6.0.0</td><td></td></tr>
<tr><td>1.6.1.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
</tbody>
</table>
</details>
<details>
<summary>Show all supported <a href='https://docs.haskellstack.org/en/stable/README/'>Stack</a> versions</summary>
<table>
<thead><tr><th>Stack Version</th><th>Tags</th></tr></thead>
<tbody>
<tr><td>2.5.1</td><td></td></tr>
<tr><td>2.7.1</td><td></td></tr>
<tr><td>2.7.3</td><td></td></tr>
<tr><td>2.7.5</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
</tbody>
</table>
</details>
## Supported platforms ## Supported platforms

View File

@@ -121,7 +121,7 @@ library
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, lzma-static ^>=5.2.5.3 , lzma-static ^>=5.2.5.3
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.3
, mtl ^>=2.2 , mtl ^>=2.2
, optics ^>=0.4 , optics ^>=0.4
, os-release ^>=1.0.0 , os-release ^>=1.0.0
@@ -236,19 +236,23 @@ executable ghcup
, ghcup , ghcup
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.3
, mtl ^>=2.2 , 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 ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0 , pretty-terminal ^>=0.1.0.0
, process ^>=1.6.11.0
, resourcet ^>=1.2.2 , resourcet ^>=1.2.2
, safe ^>=0.3.18 , safe ^>=0.3.18
, safe-exceptions ^>=0.1 , safe-exceptions ^>=0.1
, temporary ^>=1.3 , tagsoup ^>=0.14
, template-haskell >=2.7 && <2.18 , template-haskell >=2.7 && <2.18
, temporary ^>=1.3
, text ^>=1.2.4.0 , text ^>=1.2.4.0
, unordered-containers ^>=0.2
, uri-bytestring ^>=0.3.2.2 , uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0 , utf8-string ^>=1.0
, vector ^>=0.12
, versions >=4.0.1 && <5.1 , versions >=4.0.1 && <5.1
, yaml-streamly ^>=0.12.0 , yaml-streamly ^>=0.12.0
@@ -262,23 +266,22 @@ executable ghcup
, brick ^>=0.64 , brick ^>=0.64
, transformers ^>=0.5 , transformers ^>=0.5
, unix ^>=2.7 , unix ^>=2.7
, vector ^>=0.12
, vty >=5.28.2 && <5.34 , vty >=5.28.2 && <5.34
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
else else
build-depends: build-depends: unix ^>=2.7
, unix ^>=2.7
if flag(no-exe) if flag(no-exe)
buildable: False buildable: False
if (flag(disable-upgrade)) if flag(disable-upgrade)
cpp-options: -DDISABLE_UPGRADE cpp-options: -DDISABLE_UPGRADE
else else
other-modules: other-modules: GHCup.OptParse.Upgrade
GHCup.OptParse.Upgrade
test-suite ghcup-test test-suite ghcup-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
@@ -307,9 +310,9 @@ test-suite ghcup-test
, base >=4.12 && <5 , base >=4.12 && <5
, bytestring ^>=0.10 , bytestring ^>=0.10
, containers ^>=0.6 , containers ^>=0.6
, generic-arbitrary ^>=0.1.0 , generic-arbitrary >=0.1.0 && <0.3
, ghcup , ghcup
, hspec ^>=2.7.10 , hspec >=2.7.10 && <2.10
, hspec-golden-aeson ^>=0.9 , hspec-golden-aeson ^>=0.9
, QuickCheck ^>=2.14.1 , QuickCheck ^>=2.14.1
, quickcheck-arbitrary-adt ^>=0.3.1.0 , quickcheck-arbitrary-adt ^>=0.3.1.0

View File

@@ -1,4 +1,4 @@
resolver: lts-18.25 resolver: lts-18.27
packages: packages:
- . - .
@@ -16,6 +16,7 @@ extra-deps:
- composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
- haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466 - haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298 - haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
- haskus-utils-variant-3.2.1@sha256:791f4cf1e786eb578f4d37aef60986641f84c36e130164321f7d01542584066a,2200
- heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340 - heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269 - hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615 - hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
@@ -39,11 +40,6 @@ extra-deps:
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- yaml-streamly-0.12.0 - yaml-streamly-0.12.0
- git: https://github.com/hasufell/packages.git
commit: cc0b4688f8bb374fa92f17c856949de795b56291
subdirs:
- haskus-utils-variant
flags: flags:
http-io-streams: http-io-streams:
brotli: false brotli: false