ghcup-hs/app/ghcup/Main.hs

2677 lines
97 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
import BrickMain ( brickMain )
#endif
2020-01-11 20:15:05 +00:00
import GHCup
import GHCup.Download
import GHCup.Errors
2020-04-10 15:36:27 +00:00
import GHCup.Platform
import GHCup.Requirements
2020-01-11 20:15:05 +00:00
import GHCup.Types
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import GHCup.Utils
2020-04-17 14:56:56 +00:00
import GHCup.Utils.File
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Logger
2020-04-25 10:06:41 +00:00
import GHCup.Utils.MegaParsec
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Prelude
2020-07-04 19:49:59 +00:00
import GHCup.Utils.String.QQ
2020-01-11 20:15:05 +00:00
import GHCup.Version
2021-08-27 12:37:44 +00:00
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
import Codec.Archive
import Control.Concurrent
import Control.Concurrent.Async
2021-07-15 11:32:48 +00:00
import Control.DeepSeq ( force )
import Control.Exception ( evaluate )
import Control.Exception.Safe
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Reader
import Control.Monad.Trans.Resource
2021-08-27 12:37:44 +00:00
import Data.Aeson ( decodeStrict', Value )
import Data.Aeson.Encode.Pretty ( encodePretty )
2020-01-11 20:15:05 +00:00
import Data.Bifunctor
import Data.Char
2020-03-09 21:21:22 +00:00
import Data.Either
2020-03-17 00:58:59 +00:00
import Data.Functor
2021-02-25 17:21:25 +00:00
import Data.List ( intercalate, nub, sort, sortBy )
2020-04-22 14:13:58 +00:00
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe
2020-03-17 00:58:59 +00:00
import Data.Text ( Text )
2020-04-25 10:06:41 +00:00
import Data.Versions hiding ( str )
2020-03-17 00:58:59 +00:00
import Data.Void
import GHC.IO.Encoding
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
2020-04-17 14:56:56 +00:00
import Language.Haskell.TH
2021-09-04 13:10:07 +00:00
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
2020-01-11 20:15:05 +00:00
import Options.Applicative hiding ( style )
2020-04-17 20:11:41 +00:00
import Options.Applicative.Help.Pretty ( text )
2020-01-11 20:15:05 +00:00
import Prelude hiding ( appendFile )
import Safe
import System.Console.Pretty hiding ( color )
import qualified System.Console.Pretty as Pretty
2020-01-11 20:15:05 +00:00
import System.Environment
import System.Exit
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO hiding ( appendFile )
import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-01-11 20:15:05 +00:00
import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
2021-02-25 15:13:00 +00:00
import qualified Data.Map.Strict as M
2020-01-11 20:15:05 +00:00
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
2021-08-30 21:04:28 +00:00
import qualified Data.YAML.Aeson as Y
2020-03-17 00:58:59 +00:00
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
2020-01-11 20:15:05 +00:00
data Options = Options
{
-- global options
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
2020-01-11 20:15:05 +00:00
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
2021-07-18 21:29:09 +00:00
, optNoNetwork :: Maybe Bool
2020-01-11 20:15:05 +00:00
-- commands
, optCommand :: Command
}
data Command
= Install (Either InstallCommand InstallOptions)
| InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions)
2020-01-11 20:15:05 +00:00
| List ListOptions
| Rm (Either RmCommand RmOptions)
2020-01-11 20:15:05 +00:00
| DInfo
| Compile CompileCommand
2021-08-03 06:09:47 +00:00
| Config ConfigCommand
| Whereis WhereisOptions WhereisCommand
| Upgrade UpgradeOpts Bool
2020-04-10 15:36:27 +00:00
| ToolRequirements
| ChangeLog ChangeLogOptions
| Nuke
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
| Interactive
#endif
2021-07-19 14:49:18 +00:00
| Prefetch PrefetchCommand
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
2020-01-11 20:15:05 +00:00
| ToolTag Tag
2020-04-22 14:13:58 +00:00
prettyToolVer :: ToolVersion -> String
prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
2020-04-22 14:13:58 +00:00
prettyToolVer (ToolTag t) = show t
2021-02-25 17:21:25 +00:00
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer Nothing = SetRecommended
2020-01-11 20:15:05 +00:00
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
2021-05-14 22:31:36 +00:00
| InstallStack InstallOptions
2020-01-11 20:15:05 +00:00
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
2020-01-11 20:15:05 +00:00
}
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
| SetHLS SetOptions
2021-05-14 22:31:36 +00:00
| SetStack SetOptions
2021-02-25 17:21:25 +00:00
-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
| SetToolTag Tag
| SetRecommended
| SetNext
data SetOptions = SetOptions
2021-02-25 17:21:25 +00:00
{ sToolVer :: SetToolVersion
2020-01-11 20:15:05 +00:00
}
data ListOptions = ListOptions
{ loTool :: Maybe Tool
2020-04-22 10:30:02 +00:00
, lCriteria :: Maybe ListCriteria
, lRawFormat :: Bool
2020-01-11 20:15:05 +00:00
}
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
2021-05-14 22:31:36 +00:00
| RmStack Version
2020-01-11 20:15:05 +00:00
data RmOptions = RmOptions
2020-04-25 10:06:41 +00:00
{ ghcVer :: GHCTargetVersion
2020-01-11 20:15:05 +00:00
}
2020-04-25 10:06:41 +00:00
data CompileCommand = CompileGHC GHCCompileOptions
2020-01-11 20:15:05 +00:00
2021-08-03 06:09:47 +00:00
data ConfigCommand = ShowConfig | SetConfig String String | InitConfig
2020-04-25 10:06:41 +00:00
data GHCCompileOptions = GHCCompileOptions
2021-04-28 16:45:48 +00:00
{ targetGhc :: Either Version GitBranch
2021-05-14 21:09:45 +00:00
, bootstrapGhc :: Either Version FilePath
2020-04-25 10:06:41 +00:00
, jobs :: Maybe Int
2021-05-14 21:09:45 +00:00
, buildConfig :: Maybe FilePath
, patchDir :: Maybe FilePath
2020-04-25 10:06:41 +00:00
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
, setCompile :: Bool
2021-06-05 20:26:35 +00:00
, ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String
, hadrian :: Bool
, isolateDir :: Maybe FilePath
2020-04-25 10:06:41 +00:00
}
2020-01-11 20:15:05 +00:00
data UpgradeOpts = UpgradeInplace
2021-05-14 21:09:45 +00:00
| UpgradeAt FilePath
2020-01-11 20:15:05 +00:00
| UpgradeGHCupDir
deriving Show
data ChangeLogOptions = ChangeLogOptions
{ clOpen :: Bool
, clTool :: Maybe Tool
, clToolVer :: Maybe ToolVersion
}
2020-01-11 20:15:05 +00:00
data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
| WhereisBaseDir
| WhereisBinDir
| WhereisCacheDir
| WhereisLogsDir
| WhereisConfDir
data WhereisOptions = WhereisOptions {
directory :: Bool
}
2021-07-19 14:49:18 +00:00
data PrefetchOptions = PrefetchOptions {
pfCacheDir :: Maybe FilePath
}
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
| PrefetchCabal PrefetchOptions (Maybe ToolVersion)
| PrefetchHLS PrefetchOptions (Maybe ToolVersion)
| PrefetchStack PrefetchOptions (Maybe ToolVersion)
| PrefetchMetadata
data PrefetchGHCOptions = PrefetchGHCOptions {
pfGHCSrc :: Bool
, pfGHCCacheDir :: Maybe FilePath
}
-- https://github.com/pcapriotti/optparse-applicative/issues/148
-- | A switch that can be enabled using --foo and disabled using --no-foo.
--
-- The option modifier is applied to only the option that is *not* enabled
-- by default. For example:
--
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
--
-- This example makes --recursive enabled by default, so
-- the help is shown only for --no-recursive.
invertableSwitch
:: String -- ^ long option
-> Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier
-> Parser (Maybe Bool)
invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv
(if defv then mempty else optmod)
(if defv then optmod else mempty)
-- | Allows providing option modifiers for both --foo and --no-foo.
invertableSwitch'
:: String -- ^ long option (eg "foo")
-> 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)
)
where
nolongopt = "no-" ++ longopt
2020-01-11 20:15:05 +00:00
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)")
2020-01-11 20:15:05 +00:00
<*> (optional
(option
(eitherReader parseUri)
2020-03-09 21:21:22 +00:00
( short 's'
<> long "url-source"
<> metavar "URL"
<> help "Alternative ghcup download info url"
<> internal
2020-01-11 20:15:05 +00:00
)
)
)
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
<*> optional (option
2020-04-22 16:12:40 +00:00
(eitherReader keepOnParser)
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories? (default: errors)"
2020-04-29 17:12:58 +00:00
<> hidden
))
<*> optional (option
2020-04-29 17:12:58 +00:00
(eitherReader downloaderParser)
( long "downloader"
#if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>"
<> help
"Downloader to use (default: internal)"
#else
<> metavar "<curl|wget>"
<> help
"Downloader to use (default: curl)"
#endif
<> hidden
))
2021-07-18 21:29:09 +00:00
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
2020-01-11 20:15:05 +00:00
<*> com
where
parseUri s' =
2021-03-11 16:03:51 +00:00
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
2020-01-11 20:15:05 +00:00
com :: Parser Command
com =
subparser
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
2020-01-11 20:15:05 +00:00
( command
2020-07-06 20:39:16 +00:00
"tui"
( (\_ -> Interactive)
<$> (info
helper
( progDesc "Start the interactive GHCup UI"
)
)
)
<> command
#else
( command
#endif
2020-01-11 20:15:05 +00:00
"install"
( Install
2021-03-11 16:03:51 +00:00
<$> info
(installParser <**> helper)
2021-06-06 09:59:51 +00:00
( progDesc "Install or update GHC/cabal/HLS"
<> footerDoc (Just $ text installToolFooter)
)
2020-01-11 20:15:05 +00:00
)
<> command
"set"
2021-03-11 16:03:51 +00:00
(info
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
<> command
"rm"
2021-03-11 16:03:51 +00:00
(info
(Rm <$> rmParser <**> helper)
2021-06-06 09:59:51 +00:00
( progDesc "Remove a GHC/cabal/HLS version"
2021-03-11 16:03:51 +00:00
<> footerDoc (Just $ text rmFooter)
)
)
2020-01-11 20:15:05 +00:00
<> command
"list"
2021-03-11 16:03:51 +00:00
(info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
2020-01-11 20:15:05 +00:00
)
<> command
"upgrade"
(info
( (Upgrade <$> upgradeOptsP <*> switch
(short 'f' <> long "force" <> help "Force update")
)
<**> helper
)
(progDesc "Upgrade ghcup")
)
2020-03-09 21:21:22 +00:00
<> command
"compile"
( Compile
2021-03-11 16:03:51 +00:00
<$> info (compileP <**> helper)
(progDesc "Compile a tool from source")
2020-03-09 21:21:22 +00:00
)
<> command
"whereis"
(info
( (Whereis
<$> (WhereisOptions <$> switch (short 'd' <> long "directory" <> help "return directory of the binary instead of the binary location"))
<*> whereisP
) <**> helper
)
(progDesc "Find a tools location"
<> footerDoc ( Just $ text whereisFooter ))
)
2021-07-19 14:49:18 +00:00
<> command
"prefetch"
(info
( (Prefetch
<$> prefetchP
) <**> helper
)
(progDesc "Prefetch assets"
<> footerDoc ( Just $ text prefetchFooter ))
)
2020-01-11 20:15:05 +00:00
<> commandGroup "Main commands:"
)
<|> subparser
( command
"debug-info"
2021-03-11 16:03:51 +00:00
((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
2020-04-10 15:36:27 +00:00
<> command
"tool-requirements"
( (\_ -> ToolRequirements)
2021-03-11 16:03:51 +00:00
<$> info helper
(progDesc "Show the requirements for ghc/cabal")
2020-04-10 15:36:27 +00:00
)
<> command
"changelog"
2021-03-11 16:03:51 +00:00
(info
(fmap ChangeLog changelogP <**> helper)
( progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
)
2021-08-03 06:09:47 +00:00
<> command
"config"
( Config
<$> info (configP <**> helper)
(progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
)
2020-01-11 20:15:05 +00:00
<> commandGroup "Other commands:"
<> hidden
)
<|> subparser
( command
"install-cabal"
2021-03-11 16:03:51 +00:00
(info
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
<> internal
)
<|> subparser
(command
"nuke"
(info (pure Nuke <**> helper)
(progDesc "Completely remove ghcup from your system"))
<> commandGroup "Nuclear Commands:"
)
2020-04-17 20:11:41 +00:00
where
installToolFooter :: String
2020-07-04 19:49:59 +00:00
installToolFooter = [s|Discussion:
Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag.
2020-10-25 09:54:57 +00:00
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
setFooter :: String
2020-07-04 19:49:59 +00:00
setFooter = [s|Discussion:
Sets the currently active GHC or cabal version. When no command is given,
defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version).
2020-10-25 09:54:57 +00:00
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
rmFooter :: String
2020-07-04 19:49:59 +00:00
rmFooter = [s|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
2020-10-25 09:54:57 +00:00
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
changeLogFooter :: String
2020-07-04 19:49:59 +00:00
changeLogFooter = [s|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
whereisFooter :: String
whereisFooter = [s|Discussion:
Finds the location of a tool. For GHC, this is the ghc binary, that
usually resides in a self-contained "~/.ghcup/ghc/<ghcver>" directory.
For cabal/stack/hls this the binary usually at "~/.ghcup/bin/<tool>-<ver>".
Examples:
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
ghcup whereis ghc 8.10.5
# outputs ~/.ghcup/ghc/8.10.5/bin/
ghcup whereis --directory ghc 8.10.5
# outputs ~/.ghcup/bin/cabal-3.4.0.0
ghcup whereis cabal 3.4.0.0
# outputs ~/.ghcup/bin/
ghcup whereis --directory cabal 3.4.0.0|]
2021-07-19 14:49:18 +00:00
prefetchFooter :: String
prefetchFooter = [s|Discussion:
Prefetches tools or assets into "~/.ghcup/cache" directory. This can
be then combined later with '--offline' flag, ensuring all assets that
are required for offline use have been prefetched.
Examples:
ghcup prefetch metadata
ghcup prefetch ghc 8.10.5
ghcup --offline install ghc 8.10.5|]
2021-08-03 06:09:47 +00:00
configFooter :: String
configFooter = [s|Examples:
# show current config
ghcup config
# initialize config
ghcup config init
# set <key> <value> configuration pair
ghcup config <key> <value>|]
installCabalFooter :: String
2020-07-04 19:49:59 +00:00
installCabalFooter = [s|Discussion:
2020-04-17 20:11:41 +00:00
Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by
default. Make sure to set up your PATH appropriately, so the cabal
installation takes precedence.|]
installParser :: Parser (Either InstallCommand InstallOptions)
installParser =
(Left <$> subparser
( command
"ghc"
( InstallGHC
2021-03-11 16:03:51 +00:00
<$> info
(installOpts (Just GHC) <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
<> command
"cabal"
( InstallCabal
2021-03-11 16:03:51 +00:00
<$> info
(installOpts (Just Cabal) <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
<> command
"hls"
( InstallHLS
2021-03-11 16:03:51 +00:00
<$> info
(installOpts (Just HLS) <**> helper)
( progDesc "Install haskell-languge-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
2021-05-14 22:31:36 +00:00
<> command
"stack"
( InstallStack
<$> info
(installOpts (Just Stack) <**> helper)
( progDesc "Install stack"
<> footerDoc (Just $ text installStackFooter)
)
)
)
)
<|> (Right <$> installOpts Nothing)
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
Installs haskell-language-server binaries and wrapper
into "~/.ghcup/bin"
Examples:
2021-05-14 22:31:36 +00:00
# install recommended HLS
ghcup install hls|]
2021-05-14 22:31:36 +00:00
installStackFooter :: String
installStackFooter = [s|Discussion:
Installs stack binaries into "~/.ghcup/bin"
Examples:
# install recommended Stack
ghcup install stack|]
installGHCFooter :: String
2020-07-04 19:49:59 +00:00
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
2020-08-06 11:28:20 +00:00
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install recommended GHC
ghcup install ghc
# install latest GHC
ghcup install ghc latest
# install GHC 8.10.2
ghcup install ghc 8.10.2
# install GHC head fedora bindist
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
2020-01-11 20:15:05 +00:00
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b is f -> InstallOptions v p u b is f)
2021-03-11 16:03:51 +00:00
<$> optional
(option
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> ( ( (,)
2021-03-11 16:03:51 +00:00
<$> optional
(option
(eitherReader bindistParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
)
)
<*> (Just <$> toolVersionArgument Nothing tool)
)
2021-03-11 16:03:51 +00:00
<|> pure (Nothing, Nothing)
)
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated dir instead of the default one"
)
)
<*> switch
(short 'f' <> long "force" <> help "Force install")
2020-01-11 20:15:05 +00:00
setParser :: Parser (Either SetCommand SetOptions)
setParser =
(Left <$> subparser
( command
"ghc"
( SetGHC
2021-03-11 16:03:51 +00:00
<$> info
(setOpts (Just GHC) <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
)
<> command
"cabal"
( SetCabal
2021-03-11 16:03:51 +00:00
<$> info
(setOpts (Just Cabal) <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
)
<> command
"hls"
( SetHLS
2021-03-11 16:03:51 +00:00
<$> info
(setOpts (Just HLS) <**> helper)
( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter)
)
)
2021-05-14 22:31:36 +00:00
<> command
"stack"
( SetStack
<$> info
(setOpts (Just Stack) <**> helper)
( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter)
)
)
)
)
<|> (Right <$> setOpts Nothing)
where
setGHCFooter :: String
2020-07-04 19:49:59 +00:00
setGHCFooter = [s|Discussion:
Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|]
setCabalFooter :: String
2020-07-04 19:49:59 +00:00
setCabalFooter = [s|Discussion:
Sets the the current Cabal version.|]
2021-05-14 22:31:36 +00:00
setStackFooter :: String
setStackFooter = [s|Discussion:
Sets the the current Stack version.|]
setHLSFooter :: String
setHLSFooter = [s|Discussion:
Sets the the current haskell-language-server version.|]
setOpts :: Maybe Tool -> Parser SetOptions
2021-02-25 17:21:25 +00:00
setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$>
optional (setVersionArgument (Just ListInstalled) tool))
2020-01-11 20:15:05 +00:00
listOpts :: Parser ListOptions
listOpts =
ListOptions
<$> optional
(option
(eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
"Tool to list versions for. Default is all"
)
)
2021-03-11 16:03:51 +00:00
<*> optional
2020-01-11 20:15:05 +00:00
(option
(eitherReader criteriaParser)
( short 'c'
<> long "show-criteria"
<> metavar "<installed|set>"
<> help "Show only installed or set tool versions"
)
)
2020-04-22 10:30:02 +00:00
<*> switch
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
)
2020-01-11 20:15:05 +00:00
rmParser :: Parser (Either RmCommand RmOptions)
rmParser =
(Left <$> subparser
( command
"ghc"
2021-03-11 16:03:51 +00:00
(RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
<> command
"cabal"
( RmCabal
2021-03-11 16:03:51 +00:00
<$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
(progDesc "Remove Cabal version")
)
<> command
"hls"
( RmHLS
2021-03-11 16:03:51 +00:00
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
2021-05-14 22:31:36 +00:00
<> command
"stack"
( RmStack
<$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
(progDesc "Remove stack version")
)
)
)
<|> (Right <$> rmOpts Nothing)
rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool
2020-01-11 20:15:05 +00:00
changelogP :: Parser ChangeLogOptions
changelogP =
(\x y -> ChangeLogOptions x y)
<$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
2021-03-11 16:03:51 +00:00
<*> optional
(option
(eitherReader
(\s' -> case fmap toLower s' of
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
2021-05-14 22:31:36 +00:00
"stack" -> Right Stack
2021-03-11 16:03:51 +00:00
e -> Left e
)
)
(short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)"
)
)
<*> optional (toolVersionArgument Nothing Nothing)
2020-01-11 20:15:05 +00:00
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
2021-03-11 16:03:51 +00:00
<$> info
2020-04-25 10:06:41 +00:00
(ghcCompileOpts <**> helper)
( progDesc "Compile GHC from source"
<> footerDoc (Just $ text compileFooter)
)
2020-01-11 20:15:05 +00:00
)
)
2020-04-17 20:11:41 +00:00
where
2020-07-04 19:49:59 +00:00
compileFooter = [s|Discussion:
2020-04-17 20:11:41 +00:00
Compiles and installs the specified GHC version into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
2020-04-25 10:06:41 +00:00
This also allows building a cross-compiler. Consult the documentation
first: <https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#configuring-the-build>
ENV variables:
Various toolchain variables will be passed onto the ghc build system,
such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
2020-04-17 20:11:41 +00:00
Examples:
2021-04-28 16:45:48 +00:00
# compile from known version
2020-04-17 20:11:41 +00:00
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
2021-04-28 16:45:48 +00:00
# compile from git commit/reference
ghcup compile ghc -j 4 -g master -b 8.2.2
2020-04-25 10:06:41 +00:00
# specify path to bootstrap ghc
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
# build cross compiler
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
2020-04-17 20:11:41 +00:00
2021-08-03 06:09:47 +00:00
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
<> command "set" setP -- [set] KEY VALUE at help lhs
<> command "show" showP
)
<|> argsP -- add show for a single option
<|> pure ShowConfig
where
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
setP = info argsP (progDesc "Set config KEY to VALUE")
argsP = SetConfig <$> argument str (metavar "KEY") <*> argument str (metavar "VALUE")
2020-01-11 20:15:05 +00:00
whereisP :: Parser WhereisCommand
whereisP = subparser
(commandGroup "Tools locations:" <>
command
"ghc"
(WhereisTool GHC <$> info
( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
( progDesc "Get GHC location"
<> footerDoc (Just $ text whereisGHCFooter ))
)
<>
command
"cabal"
(WhereisTool Cabal <$> info
( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )
( progDesc "Get cabal location"
<> footerDoc (Just $ text whereisCabalFooter ))
)
<>
command
"hls"
(WhereisTool HLS <$> info
( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )
( progDesc "Get HLS location"
<> footerDoc (Just $ text whereisHLSFooter ))
)
<>
command
"stack"
(WhereisTool Stack <$> info
( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )
( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter ))
)
<>
command
"ghcup"
(WhereisTool GHCup <$> info ( (pure Nothing) <**> helper ) ( progDesc "Get ghcup location" ))
) <|> subparser ( commandGroup "Directory locations:"
<>
command
"basedir"
(info (pure WhereisBaseDir <**> helper)
( progDesc "Get ghcup base directory location" )
)
<>
command
"bindir"
(info (pure WhereisBinDir <**> helper)
( progDesc "Get ghcup binary directory location" )
)
<>
command
"cachedir"
(info (pure WhereisCacheDir <**> helper)
( progDesc "Get ghcup cache directory location" )
)
<>
command
"logsdir"
(info (pure WhereisLogsDir <**> helper)
( progDesc "Get ghcup logs directory location" )
)
<>
command
"confdir"
(info (pure WhereisConfDir <**> helper)
( progDesc "Get ghcup config directory location" )
)
)
where
whereisGHCFooter = [s|Discussion:
Finds the location of a GHC executable, which usually resides in
a self-contained "~/.ghcup/ghc/<ghcver>" directory.
Examples:
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
ghcup whereis ghc 8.10.5
# outputs ~/.ghcup/ghc/8.10.5/bin/
ghcup whereis --directory ghc 8.10.5 |]
whereisCabalFooter = [s|Discussion:
Finds the location of a Cabal executable, which usually resides in
"~/.ghcup/bin/".
Examples:
# outputs ~/.ghcup/bin/cabal-3.4.0.0
ghcup whereis cabal 3.4.0.0
# outputs ~/.ghcup/bin
ghcup whereis --directory cabal 3.4.0.0|]
whereisHLSFooter = [s|Discussion:
Finds the location of a HLS executable, which usually resides in
"~/.ghcup/bin/".
Examples:
# outputs ~/.ghcup/bin/haskell-language-server-wrapper-1.2.0
ghcup whereis hls 1.2.0
# outputs ~/.ghcup/bin/
ghcup whereis --directory hls 1.2.0|]
whereisStackFooter = [s|Discussion:
Finds the location of a stack executable, which usually resides in
"~/.ghcup/bin/".
Examples:
# outputs ~/.ghcup/bin/stack-2.7.1
ghcup whereis stack 2.7.1
# outputs ~/.ghcup/bin/
ghcup whereis --directory stack 2.7.1|]
2021-07-19 14:49:18 +00:00
prefetchP :: Parser PrefetchCommand
prefetchP = subparser
( command
"ghc"
(info
(PrefetchGHC
<$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just GHC)) ))
( progDesc "Download GHC assets for installation")
)
<>
command
"cabal"
(info
(PrefetchCabal
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation")
)
<>
command
"hls"
(info
(PrefetchHLS
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation")
)
<>
command
"stack"
(info
(PrefetchStack
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation")
)
<>
command
"metadata"
(const PrefetchMetadata <$> info
helper
( progDesc "Download ghcup's metadata, needed for various operations")
)
)
2020-04-25 10:06:41 +00:00
ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts =
2021-04-28 16:45:48 +00:00
GHCCompileOptions
<$> ((Left <$> option
2020-01-11 20:15:05 +00:00
(eitherReader
2021-03-11 16:03:51 +00:00
(first (const "Not a valid version") . version . T.pack)
2020-01-11 20:15:05 +00:00
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
2021-04-28 16:45:48 +00:00
) <|>
(Right <$> (GitBranch <$> option
str
(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)"))
)))
2021-03-11 16:03:51 +00:00
<*> option
2020-01-11 20:15:05 +00:00
(eitherReader
(\x ->
2021-05-14 21:09:45 +00:00
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
)
2020-01-11 20:15:05 +00:00
)
( short 'b'
<> long "bootstrap-ghc"
<> metavar "BOOTSTRAP_GHC"
<> help
"The GHC version (or full path) to bootstrap with (must be installed)"
2020-01-11 20:15:05 +00:00
)
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
)
)
<*> optional
(option
2021-05-14 21:09:45 +00:00
str
2020-01-11 20:15:05 +00:00
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
)
)
<*> optional
(option
2021-05-14 21:09:45 +00:00
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
)
2021-04-28 16:45:48 +00:00
<*> optional
(option
str
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
"Build cross-compiler for this platform"
)
)
<*> 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"
)
2021-06-05 20:26:35 +00:00
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(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'"
)
)
<*> optional
(option
str
(short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
"Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
)
)
<*> switch
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
)
)
2020-01-11 20:15:05 +00:00
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP' <|> toolP
2020-01-11 20:15:05 +00:00
where
verP' = ToolVersion <$> versionParser
2020-01-11 20:15:05 +00:00
toolP =
ToolTag
2021-03-11 16:03:51 +00:00
<$> option
(eitherReader tagEither)
2020-01-11 20:15:05 +00:00
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
-- | same as toolVersionParser, except as an argument.
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument criteria tool =
2021-02-25 15:13:00 +00:00
argument (eitherReader toolVersionEither)
(metavar "VERSION|TAG"
2021-02-25 17:21:25 +00:00
<> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
setVersionArgument criteria tool =
argument (eitherReader setEither)
(metavar "VERSION|TAG|next"
<> completer (tagCompleter (fromMaybe GHC tool) ["next"])
2021-02-25 15:13:00 +00:00
<> foldMap (completer . versionCompleter criteria) tool)
2021-02-25 17:21:25 +00:00
where
setEither s' =
parseSet s'
2021-03-11 16:03:51 +00:00
<|> second SetToolTag (tagEither s')
<|> second SetToolVersion (tVersionEither s')
2021-02-25 17:21:25 +00:00
parseSet s' = case fmap toLower s' of
"next" -> Right SetNext
2021-08-25 16:54:58 +00:00
other -> Left $ "Unknown tag/version " <> other
versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
2021-02-25 17:21:25 +00:00
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
2021-02-25 15:13:00 +00:00
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
2021-08-30 20:41:58 +00:00
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
loggerConfig
2021-07-18 21:29:09 +00:00
2021-08-30 20:41:58 +00:00
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
2021-02-25 15:13:00 +00:00
case mGhcUpInfo of
2021-05-14 21:09:45 +00:00
VRight ghcupInfo -> do
2021-02-25 15:13:00 +00:00
let allTags = filter (\t -> t /= Old)
$ join
$ fmap _viTags
2021-02-25 15:13:00 +00:00
$ M.elems
2021-05-14 21:09:45 +00:00
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool
pure $ nub $ (add ++) $ fmap tagToString allTags
2021-02-25 17:21:25 +00:00
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
2021-02-25 14:49:04 +00:00
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getAllDirs
2021-02-25 14:49:04 +00:00
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
2021-08-30 20:41:58 +00:00
let settings = Settings True False Never Curl False GHCupURL True
2021-07-18 21:29:09 +00:00
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
2021-08-30 20:41:58 +00:00
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
2021-07-18 21:29:09 +00:00
forFold mpFreq $ \pfreq -> do
2021-05-14 21:09:45 +00:00
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
2021-07-18 21:29:09 +00:00
settings
2021-05-14 21:09:45 +00:00
dirs'
defaultKeyBindings
ghcupInfo
pfreq
2021-08-30 20:41:58 +00:00
loggerConfig
2021-05-14 21:09:45 +00:00
2021-08-30 20:41:58 +00:00
runEnv = flip runReaderT appState
2021-05-14 21:09:45 +00:00
installedVersions <- runEnv $ listVersions (Just tool) criteria
2021-02-25 14:49:04 +00:00
return $ T.unpack . prettyVer . lVer <$> installedVersions
2020-04-25 10:06:41 +00:00
versionParser :: Parser GHCTargetVersion
versionParser = option
2020-04-25 10:06:41 +00:00
(eitherReader tVersionEither)
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
2020-04-22 00:33:35 +00:00
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x)
2021-08-25 16:54:58 +00:00
Left _ -> Left $ "Invalid PVP version for base " <> ver'
other -> Left $ "Unknown tag " <> other
2020-04-25 10:06:41 +00:00
tVersionEither :: String -> Either String GHCTargetVersion
tVersionEither =
2021-03-11 16:03:51 +00:00
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
2020-04-25 10:06:41 +00:00
toolVersionEither :: String -> Either String ToolVersion
toolVersionEither s' =
2021-03-11 16:03:51 +00:00
second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
2020-01-11 20:15:05 +00:00
toolParser :: String -> Either String Tool
toolParser s' | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal
| otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s')
criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s')
2020-04-22 16:12:40 +00:00
keepOnParser :: String -> Either String KeepDirs
keepOnParser s' | t == T.pack "always" = Right Always
| t == T.pack "errors" = Right Errors
| t == T.pack "never" = Right Never
| otherwise = Left ("Unknown keep value: " <> s')
where t = T.toLower (T.pack s')
2020-04-29 17:12:58 +00:00
downloaderParser :: String -> Either String Downloader
downloaderParser s' | t == T.pack "curl" = Right Curl
| t == T.pack "wget" = Right Wget
#if defined(INTERNAL_DOWNLOADER)
| t == T.pack "internal" = Right Internal
#endif
| otherwise = Left ("Unknown downloader value: " <> s')
where t = T.toLower (T.pack s')
2020-03-17 00:58:59 +00:00
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
Right r -> pure r
Left e -> Left $ errorBundlePretty e
where
archP :: MP.Parsec Void Text Architecture
2021-03-11 16:03:51 +00:00
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
2020-03-17 00:58:59 +00:00
platformP :: MP.Parsec Void Text PlatformRequest
platformP = choice'
[ (\a mv -> PlatformRequest a FreeBSD mv)
2020-03-21 21:19:37 +00:00
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "portbld"
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
2020-03-17 00:58:59 +00:00
<|> pure Nothing
)
2020-03-21 21:19:37 +00:00
<* MP.chunk "-freebsd"
2020-03-17 00:58:59 +00:00
)
, (\a mv -> PlatformRequest a Darwin mv)
2020-03-21 21:19:37 +00:00
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "apple"
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
2020-03-17 00:58:59 +00:00
<|> pure Nothing
)
2020-03-21 21:19:37 +00:00
<* MP.chunk "-darwin"
2020-03-17 00:58:59 +00:00
)
, (\a d mv -> PlatformRequest a (Linux d) mv)
2020-03-21 21:19:37 +00:00
<$> (archP <* MP.chunk "-")
2020-03-17 00:58:59 +00:00
<*> distroP
2020-03-21 21:19:37 +00:00
<*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
)
<* MP.chunk "-linux"
2020-03-17 00:58:59 +00:00
)
]
distroP :: MP.Parsec Void Text LinuxDistro
distroP = choice'
2020-03-21 21:19:37 +00:00
[ MP.chunk "debian" $> Debian
, MP.chunk "deb" $> Debian
, MP.chunk "ubuntu" $> Ubuntu
, MP.chunk "mint" $> Mint
, MP.chunk "fedora" $> Fedora
, MP.chunk "centos" $> CentOS
, MP.chunk "redhat" $> RedHat
, MP.chunk "alpine" $> Alpine
, MP.chunk "gentoo" $> Gentoo
, MP.chunk "exherbo" $> Exherbo
, MP.chunk "unknown" $> UnknownLinux
2020-03-17 00:58:59 +00:00
]
2020-04-25 10:06:41 +00:00
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
2020-03-17 00:58:59 +00:00
isolateParser :: FilePath -> Either String FilePath
isolateParser f = case isValid f of
True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir."
2020-03-17 00:58:59 +00:00
2021-05-14 21:09:45 +00:00
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings options = do
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
VRight r -> pure r
VLeft (V (JSONDecodeError e)) -> do
B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e))
pure defaultUserSettings
_ -> do
die "Unexpected error!"
2021-05-14 21:09:45 +00:00
pure $ mergeConf options userConf
where
2021-05-14 21:09:45 +00:00
mergeConf :: Options -> UserSettings -> (Settings, KeyBindings)
mergeConf Options{..} UserSettings{..} =
2020-10-25 13:17:17 +00:00
let cache = fromMaybe (fromMaybe False uCache) optCache
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
2020-10-25 13:17:17 +00:00
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
2021-07-18 21:29:09 +00:00
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
2021-05-14 21:09:45 +00:00
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
#else
defaultDownloader = Curl
#endif
mergeKeys :: UserKeyBindings -> KeyBindings
mergeKeys UserKeyBindings {..} =
let KeyBindings {..} = defaultKeyBindings
in KeyBindings {
bUp = fromMaybe bUp kUp
, bDown = fromMaybe bDown kDown
, bQuit = fromMaybe bQuit kQuit
, bInstall = fromMaybe bInstall kInstall
, bUninstall = fromMaybe bUninstall kUninstall
, bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog
2021-05-14 22:31:36 +00:00
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
}
2020-01-11 20:15:05 +00:00
2021-08-11 14:19:31 +00:00
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
2021-08-03 06:09:47 +00:00
updateSettings config settings = do
2021-08-30 21:04:28 +00:00
settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config
2021-08-11 14:19:31 +00:00
pure $ mergeConf settings' settings
2021-08-03 06:09:47 +00:00
where
mergeConf :: UserSettings -> Settings -> Settings
mergeConf UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache
noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork'
2020-01-11 20:15:05 +00:00
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
(short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
2021-03-11 16:03:51 +00:00
<$> option
2021-05-14 21:09:45 +00:00
str
2020-01-11 20:15:05 +00:00
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
2021-03-11 16:03:51 +00:00
<|> pure UpgradeGHCupDir
2020-01-11 20:15:05 +00:00
2020-04-17 14:56:56 +00:00
describe_result :: String
2021-03-11 16:03:51 +00:00
describe_result = $( LitE . StringL <$>
2020-04-17 14:56:56 +00:00
runIO (do
2021-05-14 21:09:45 +00:00
CapturedProcess{..} <- do
dirs <- liftIO getAllDirs
2021-07-18 21:29:09 +00:00
let settings = AppState (Settings True False Never Curl False GHCupURL False)
dirs
defaultKeyBindings
2021-05-14 21:09:45 +00:00
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
2020-04-17 14:56:56 +00:00
case _exitCode of
2021-05-14 21:09:45 +00:00
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
2020-04-17 14:56:56 +00:00
ExitFailure _ -> pure numericVer
)
)
2021-08-27 12:37:44 +00:00
plan_json :: String
2021-09-04 13:27:57 +00:00
plan_json = $( do
(fp, c) <- runIO (handleIO (\_ -> pure ("", "")) $ do
2021-08-27 12:37:44 +00:00
fp <- findPlanJson (ProjectRelativeToDir ".")
c <- B.readFile fp
(Just res) <- pure $ decodeStrict' @Value c
2021-09-04 13:27:57 +00:00
pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
when (not . null $ fp ) $ qAddDependentFile fp
pure . LitE . StringL $ c)
2021-08-27 12:37:44 +00:00
2021-08-11 14:19:31 +00:00
formatConfig :: UserSettings -> String
formatConfig settings
2021-08-30 21:04:28 +00:00
= UTF8.toString . Y.encode1Strict $ settings
2020-01-11 20:15:05 +00:00
main :: IO ()
main = do
2021-05-14 21:09:45 +00:00
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
void enableAnsiSupport
2020-04-17 16:54:21 +00:00
let versionHelp = infoOption
( ("The GHCup Haskell installer, version " <>)
2021-03-11 16:03:51 +00:00
(head . lines $ describe_result)
2020-04-17 16:54:21 +00:00
)
2020-04-17 20:11:41 +00:00
(long "version" <> help "Show version" <> hidden)
2021-08-27 12:37:44 +00:00
let planJson = infoOption
plan_json
(long "plan-json" <> help "Show the build-time configuration" <> internal)
2020-04-17 14:56:56 +00:00
let numericVersionHelp = infoOption
numericVer
( long "numeric-version"
<> help "Show the numeric version (for use in scripts)"
2020-04-17 20:11:41 +00:00
<> hidden
2020-04-17 14:56:56 +00:00
)
2020-04-22 18:12:57 +00:00
let listCommands = infoOption
"install set rm install-cabal list upgrade compile debug-info tool-requirements changelog"
( long "list-commands"
<> help "List available commands for shell completion"
<> internal
)
2020-01-11 20:15:05 +00:00
2020-07-04 19:49:59 +00:00
let main_footer = [s|Discussion:
2020-04-17 20:11:41 +00:00
ghcup installs the Glasgow Haskell Compiler from the official
release channels, enabling you to easily switch between different
2020-04-22 14:14:10 +00:00
versions. It maintains a self-contained ~/.ghcup directory.
ENV variables:
* TMPDIR: where ghcup does the work (unpacking, building, ...)
* GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
2020-10-25 09:54:57 +00:00
* GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
2020-04-17 20:11:41 +00:00
Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
2020-04-17 14:56:56 +00:00
customExecParser
(prefs showHelpOnError)
2021-08-27 12:37:44 +00:00
(info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands)
(footerDoc (Just $ text main_footer))
)
2020-01-11 20:15:05 +00:00
>>= \opt@Options {..} -> do
dirs@Dirs{..} <- getAllDirs
2021-05-14 21:09:45 +00:00
2020-03-17 18:16:21 +00:00
-- create ~/.ghcup dir
2021-06-13 11:41:06 +00:00
ensureDirectories dirs
(settings, keybindings) <- toSettings opt
2020-03-17 18:16:21 +00:00
2021-08-30 20:41:58 +00:00
2020-01-11 20:15:05 +00:00
-- logger interpreter
2021-08-30 20:41:58 +00:00
logfile <- flip runReaderT dirs initGHCupFileLogging
2020-07-06 20:39:16 +00:00
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
2021-08-30 20:41:58 +00:00
, colorOutter = T.hPutStr stderr
2021-07-02 21:26:07 +00:00
, rawOutter =
case optCommand of
Nuke -> \_ -> pure ()
2021-08-30 20:41:58 +00:00
_ -> T.appendFile logfile
2020-01-11 20:15:05 +00:00
}
2021-08-30 20:41:58 +00:00
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
2021-05-14 21:09:45 +00:00
2021-07-15 11:32:48 +00:00
-------------------------
-- Setting up appstate --
-------------------------
appState = do
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
2021-08-30 20:41:58 +00:00
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <-
2021-08-30 20:41:58 +00:00
( flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
2021-07-18 21:29:09 +00:00
$ getDownloadsF
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
2021-08-30 20:41:58 +00:00
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
2021-08-30 20:41:58 +00:00
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
2021-05-14 21:09:45 +00:00
2021-08-30 20:41:58 +00:00
race_ (liftIO $ flip runReaderT s' cleanupTrash)
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
case optCommand of
Nuke -> pure ()
Whereis _ _ -> pure ()
DInfo -> pure ()
ToolRequirements -> pure ()
ChangeLog _ -> pure ()
#if defined(BRICK)
Interactive -> pure ()
#endif
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
2021-08-30 20:41:58 +00:00
Nothing -> flip runReaderT s' checkForUpdates
Just _ -> pure ()
2021-07-15 11:32:48 +00:00
-- TODO: always run for windows
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
2021-08-30 20:41:58 +00:00
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
pure s'
2021-07-15 11:32:48 +00:00
2021-05-14 21:09:45 +00:00
2021-07-18 21:29:09 +00:00
#if defined(IS_WINDOWS)
-- FIXME: windows needs 'ensureGlobalTools', which requires
-- full appstate
runLeanAppState = runAppState
#else
runLeanAppState = flip runReaderT leanAppstate
2021-07-18 21:29:09 +00:00
#endif
runAppState action' = do
s' <- liftIO appState
flip runReaderT s' action'
2021-05-14 21:09:45 +00:00
2020-01-11 20:15:05 +00:00
-------------------------
-- Effect interpreters --
-------------------------
2021-07-22 13:45:08 +00:00
2021-05-14 21:09:45 +00:00
let runInstTool' appstate' mInstPlatform =
2021-08-30 20:41:58 +00:00
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
2020-01-11 20:15:05 +00:00
. runResourceT
. runE
@'[ AlreadyInstalled
, UnknownArchive
, ArchiveResult
2020-01-11 20:15:05 +00:00
, FileDoesNotExistError
, CopyError
2021-08-11 10:24:51 +00:00
, NotInstalled
, DirNotEmpty
2020-01-11 20:15:05 +00:00
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
2020-01-11 20:15:05 +00:00
]
let runInstTool mInstPlatform action' = do
s' <- liftIO appState
runInstTool' s' mInstPlatform action'
2020-03-09 21:21:22 +00:00
let
runLeanSetGHC =
2021-08-30 20:41:58 +00:00
runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
2020-03-09 21:21:22 +00:00
runSetGHC =
2021-08-30 20:41:58 +00:00
runAppState
2020-03-09 21:21:22 +00:00
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
2020-03-09 21:21:22 +00:00
]
2020-01-11 20:15:05 +00:00
let
runLeanSetCabal =
2021-08-30 20:41:58 +00:00
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetCabal =
2021-08-30 20:41:58 +00:00
runAppState
. runE
@'[ NotInstalled
, TagNotFound
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
]
let
runSetHLS =
2021-08-30 20:41:58 +00:00
runAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runLeanSetHLS =
2021-08-30 20:41:58 +00:00
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
]
2021-08-30 20:41:58 +00:00
let runListGHC = runAppState
2020-01-11 20:15:05 +00:00
2020-07-06 20:39:16 +00:00
let runRm =
2021-08-30 20:41:58 +00:00
runAppState . runE @'[NotInstalled]
2020-01-11 20:15:05 +00:00
2021-07-22 13:45:08 +00:00
let runNuke s' =
2021-08-30 20:41:58 +00:00
flip runReaderT s' . runE @'[NotInstalled]
2021-07-22 13:45:08 +00:00
2020-01-11 20:15:05 +00:00
let runDebugInfo =
2021-08-30 20:41:58 +00:00
runAppState
2020-01-11 20:15:05 +00:00
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
2021-08-30 20:41:58 +00:00
runAppState
2020-01-11 20:15:05 +00:00
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, DigestError
2020-04-10 17:27:17 +00:00
, DownloadFailed
2020-01-11 20:15:05 +00:00
, GHCupSetError
, NoDownload
2020-04-10 20:44:43 +00:00
, NotFoundInPATH
, PatchFailed
2020-01-11 20:15:05 +00:00
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
, NotInstalled
2021-08-11 10:24:51 +00:00
, DirNotEmpty
, ArchiveResult
2020-01-11 20:15:05 +00:00
]
let
runLeanWhereIs =
2021-07-19 14:56:28 +00:00
-- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate.
2021-08-30 20:41:58 +00:00
flip runReaderT leanAppstate
. runE
@'[ NotInstalled
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
runWhereIs =
2021-08-30 20:41:58 +00:00
runAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
2020-01-11 20:15:05 +00:00
let runUpgrade =
2021-08-30 20:41:58 +00:00
runAppState
2020-01-11 20:15:05 +00:00
. runResourceT
. runE
@'[ DigestError
, NoDownload
, NoUpdate
2020-01-11 20:15:05 +00:00
, FileDoesNotExistError
, CopyError
2020-03-09 21:21:22 +00:00
, DownloadFailed
2020-01-11 20:15:05 +00:00
]
2021-07-19 14:49:18 +00:00
let runPrefetch =
2021-08-30 20:41:58 +00:00
runAppState
2021-07-19 14:49:18 +00:00
. runResourceT
. runE
@'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, DownloadFailed
, JSONError
, FileDoesNotExistError
]
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v) isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
>>= \case
VRight vi -> do
2021-08-30 20:41:58 +00:00
runLogger $ logInfo "GHC installation successful"
2021-03-11 16:03:51 +00:00
forM_ (_viPostInstall =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logWarn $
2021-08-25 16:54:58 +00:00
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
2020-10-23 23:06:53 +00:00
case keepDirs settings of
2021-08-30 20:41:58 +00:00
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
2021-08-25 16:54:58 +00:00
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
2021-08-30 20:41:58 +00:00
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3
let installCabal InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) isolateDir forceInstall
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
VRight vi -> do
2021-08-30 20:41:58 +00:00
runLogger $ logInfo "Cabal installation successful"
2021-03-11 16:03:51 +00:00
forM_ (_viPostInstall =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logWarn $
2021-08-25 16:54:58 +00:00
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
2021-08-30 20:41:58 +00:00
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) isolateDir
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
)
>>= \case
VRight vi -> do
2021-08-30 20:41:58 +00:00
runLogger $ logInfo "HLS installation successful"
2021-03-11 16:03:51 +00:00
forM_ (_viPostInstall =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logWarn $
2021-08-25 16:54:58 +00:00
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls "
<> prettyVer v
<> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
2021-08-30 20:41:58 +00:00
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
2021-05-14 22:31:36 +00:00
let installStack InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) isolateDir
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
2021-05-14 22:31:36 +00:00
)
>>= \case
VRight vi -> do
2021-08-30 20:41:58 +00:00
runLogger $ logInfo "Stack installation successful"
2021-05-14 22:31:36 +00:00
forM_ (_viPostInstall =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
2021-05-14 22:31:36 +00:00
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logWarn $
2021-08-25 16:54:58 +00:00
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack " <> prettyVer v <> "' first"
2021-05-14 22:31:36 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ do
2021-08-30 20:41:58 +00:00
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
2021-05-14 22:31:36 +00:00
pure $ ExitFailure 4
let setGHC' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
_ -> runSetGHC (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
2021-03-11 16:03:51 +00:00
VRight GHCTargetVersion{..} -> do
runLogger
2021-08-30 20:41:58 +00:00
$ logInfo $
2021-08-25 16:54:58 +00:00
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 5
let setCabal' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
_ -> runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
>>= \case
2021-03-11 16:03:51 +00:00
VRight GHCTargetVersion{..} -> do
2021-02-25 17:21:25 +00:00
runLogger
2021-08-30 20:41:58 +00:00
$ logInfo $
2021-08-25 16:54:58 +00:00
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
2021-02-25 17:21:25 +00:00
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setHLS' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
_ -> runSetHLS (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
>>= \case
2021-03-11 16:03:51 +00:00
VRight GHCTargetVersion{..} -> do
2021-02-25 17:21:25 +00:00
runLogger
2021-08-30 20:41:58 +00:00
$ logInfo $
2021-08-25 16:54:58 +00:00
"HLS " <> prettyVer _tvVersion <> " successfully set as default version"
2021-02-25 17:21:25 +00:00
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setStack' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
_ -> runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v)
pure v
)
2021-05-14 22:31:36 +00:00
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
2021-08-30 20:41:58 +00:00
$ logInfo $
2021-08-25 16:54:58 +00:00
"Stack " <> prettyVer _tvVersion <> " successfully set as default version"
2021-05-14 22:31:36 +00:00
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
2021-05-14 22:31:36 +00:00
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
2021-03-11 16:03:51 +00:00
runRm (do
liftE $
rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
)
>>= \case
VRight vi -> do
2021-03-11 16:03:51 +00:00
forM_ (_viPostRemove =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 7
let rmCabal' tv =
2021-03-11 16:03:51 +00:00
runRm (do
liftE $
rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls)
)
>>= \case
VRight vi -> do
2021-03-11 16:03:51 +00:00
forM_ (_viPostRemove =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmHLS' tv =
2021-03-11 16:03:51 +00:00
runRm (do
liftE $
rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls)
)
>>= \case
VRight vi -> do
2021-03-11 16:03:51 +00:00
forM_ (_viPostRemove =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
2021-05-14 22:31:36 +00:00
let rmStack' tv =
runRm (do
liftE $
rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 22:31:36 +00:00
pure (getVersionInfo tv Stack dls)
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
2021-05-14 22:31:36 +00:00
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
2021-05-14 22:31:36 +00:00
pure $ ExitFailure 15
res <- case optCommand of
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
2021-05-14 21:09:45 +00:00
Interactive -> do
2021-07-18 21:29:09 +00:00
s' <- appState
2021-08-30 20:41:58 +00:00
liftIO $ brickMain s' >> pure ExitSuccess
2020-07-06 20:39:16 +00:00
#endif
Install (Right iopts) -> do
2021-08-30 20:41:58 +00:00
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
2021-05-14 22:31:36 +00:00
Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do
2021-08-30 20:41:58 +00:00
runLogger (logWarn "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.")
installCabal iopts
Set (Right sopts) -> do
2021-08-30 20:41:58 +00:00
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
Set (Left (SetHLS sopts)) -> setHLS' sopts
2021-05-14 22:31:36 +00:00
Set (Left (SetStack sopts)) -> setStack' sopts
2020-01-11 20:15:05 +00:00
2021-03-11 16:03:51 +00:00
List ListOptions {..} ->
runListGHC (do
2021-05-14 21:09:45 +00:00
l <- listVersions loTool lCriteria
2020-07-13 16:27:21 +00:00
liftIO $ printListResult lRawFormat l
pure ExitSuccess
2020-04-17 16:54:21 +00:00
)
2020-01-11 20:15:05 +00:00
Rm (Right rmopts) -> do
2021-08-30 20:41:58 +00:00
runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
2021-05-14 22:31:36 +00:00
Rm (Left (RmStack rmopts)) -> rmStack' rmopts
2020-01-11 20:15:05 +00:00
2020-04-17 16:54:21 +00:00
DInfo ->
2021-03-11 16:03:51 +00:00
do runDebugInfo $ liftE getDebugInfo
2020-01-11 20:15:05 +00:00
>>= \case
2020-04-17 16:26:55 +00:00
VRight dinfo -> do
putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 8
2020-01-11 20:15:05 +00:00
Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
2020-04-25 10:06:41 +00:00
Compile (CompileGHC GHCCompileOptions {..}) ->
2021-03-11 16:03:51 +00:00
runCompileGHC (do
2021-04-28 16:45:48 +00:00
case targetGhc of
Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-04-28 16:45:48 +00:00
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
2021-08-30 20:41:58 +00:00
lift $ logInfo msg
lift $ logInfo
2021-04-28 16:45:48 +00:00
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
2021-05-14 21:09:45 +00:00
targetVer <- liftE $ compileGHC
2021-04-28 16:45:48 +00:00
(first (GHCTargetVersion crossTarget) targetGhc)
2021-06-05 20:26:35 +00:00
ovewrwiteVer
bootstrapGhc
jobs
buildConfig
patchDir
addConfArgs
buildFlavour
hadrian
isolateDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-04-28 16:45:48 +00:00
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
2021-04-28 16:45:48 +00:00
setGHC targetVer SetGHCOnly
pure (vi, targetVer)
2020-04-17 16:54:21 +00:00
)
2020-01-11 20:15:05 +00:00
>>= \case
VRight (vi, tv) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logInfo
2021-03-11 16:03:51 +00:00
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
putStr (T.unpack $ tVerToText tv)
2020-04-17 16:26:55 +00:00
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logWarn $
2021-08-25 16:54:58 +00:00
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
2020-04-17 16:26:55 +00:00
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
2020-10-23 23:06:53 +00:00
case keepDirs settings of
2021-08-30 20:41:58 +00:00
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
2021-08-25 16:54:58 +00:00
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 9
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 9
2020-01-11 20:15:05 +00:00
2021-08-03 06:09:47 +00:00
Config InitConfig -> do
path <- getConfigFilePath
2021-08-11 14:19:31 +00:00
writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
2021-08-30 20:41:58 +00:00
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
2021-08-03 06:09:47 +00:00
pure ExitSuccess
Config ShowConfig -> do
2021-08-11 14:19:31 +00:00
putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
2021-08-03 06:09:47 +00:00
pure ExitSuccess
Config (SetConfig k v) -> do
case v of
2021-08-11 14:19:31 +00:00
"" -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError "Empty values are not allowed"
2021-08-11 14:19:31 +00:00
pure $ ExitFailure 55
2021-08-03 06:09:47 +00:00
_ -> do
2021-08-11 14:19:31 +00:00
r <- runE @'[JSONError] $ do
2021-08-25 16:54:58 +00:00
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
2021-08-11 14:19:31 +00:00
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
2021-08-30 20:41:58 +00:00
runLogger $ logDebug $ T.pack $ show settings'
2021-08-11 14:19:31 +00:00
pure ()
case r of
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ "Error decoding config: " <> T.pack e
2021-08-11 14:19:31 +00:00
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
2021-08-03 06:09:47 +00:00
Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
runLeanWhereIs (do
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
putStr r
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
runWhereIs (do
(v, _) <- liftE $ fromVersion whereVer tool
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
putStr r
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis _ WhereisBaseDir -> do
putStr baseDir
pure ExitSuccess
Whereis _ WhereisBinDir -> do
putStr binDir
pure ExitSuccess
Whereis _ WhereisCacheDir -> do
putStr cacheDir
pure ExitSuccess
Whereis _ WhereisLogsDir -> do
putStr logsDir
pure ExitSuccess
Whereis _ WhereisConfDir -> do
putStr confDir
pure ExitSuccess
2021-07-15 11:32:48 +00:00
Upgrade uOpts force' -> do
2020-01-11 20:15:05 +00:00
target <- case uOpts of
2021-05-14 21:09:45 +00:00
UpgradeInplace -> Just <$> liftIO getExecutablePath
2020-01-11 20:15:05 +00:00
(UpgradeAt p) -> pure $ Just p
2021-06-13 06:36:20 +00:00
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
2020-01-11 20:15:05 +00:00
runUpgrade (do
v' <- liftE $ upgradeGHCup target force'
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (v', dls)
) >>= \case
VRight (v', dls) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
2021-08-30 20:41:58 +00:00
runLogger $ logInfo $
2021-08-25 16:54:58 +00:00
"Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg ->
2021-08-30 20:41:58 +00:00
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
2021-08-30 20:41:58 +00:00
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 11
2020-04-17 16:54:21 +00:00
ToolRequirements -> do
s' <- appState
flip runReaderT s'
2021-08-30 20:41:58 +00:00
$ (runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
GHCupInfo { .. } <- lift getGHCupInfo
platform' <- liftE getPlatform
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 12
2020-04-17 16:26:55 +00:00
2021-03-11 16:03:51 +00:00
ChangeLog ChangeLogOptions{..} -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool
ver' = maybe
(Right Latest)
(\case
2020-04-25 10:06:41 +00:00
ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion
ToolTag t -> Right t
)
clToolVer
muri = getChangeLog dls tool ver'
case muri of
Nothing -> do
runLogger
2021-08-30 20:41:58 +00:00
(logWarn $
2021-08-25 16:54:58 +00:00
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
)
pure ExitSuccess
Just uri -> do
2021-07-22 13:45:08 +00:00
s' <- appState
pfreq <- flip runReaderT s' getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
2020-07-13 21:10:17 +00:00
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
2021-05-14 21:09:45 +00:00
Windows -> "start"
2020-07-13 21:10:17 +00:00
if clOpen
then do
flip runReaderT s' $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
Right _ -> pure ExitSuccess
2021-08-30 20:41:58 +00:00
Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
2021-07-22 13:45:08 +00:00
Nuke -> do
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' (do
2021-08-30 20:41:58 +00:00
lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
2021-08-30 20:41:58 +00:00
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1"
2021-07-02 21:26:07 +00:00
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
forM_ lInstalled (liftE . rmTool)
2021-07-02 21:26:07 +00:00
lift rmGhcupDirs
) >>= \case
2021-07-02 21:26:07 +00:00
VRight leftOverFiles
| null leftOverFiles -> do
2021-08-30 20:41:58 +00:00
runLogger $ logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
2021-07-02 21:26:07 +00:00
| otherwise -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
2021-07-02 21:26:07 +00:00
forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
2021-07-19 14:49:18 +00:00
Prefetch pfCom ->
runPrefetch (do
case pfCom of
PrefetchGHC
(PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Cabal
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt HLS
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
PrefetchMetadata -> do
_ <- liftE $ getDownloadsF
pure ""
) >>= \case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
2021-08-30 20:41:58 +00:00
runLogger $ logError $ T.pack $ prettyShow e
2021-07-19 14:49:18 +00:00
pure $ ExitFailure 15
2020-04-17 16:26:55 +00:00
case res of
ExitSuccess -> pure ()
2020-04-17 18:50:23 +00:00
ef@(ExitFailure _) -> exitWith ef
2020-01-11 20:15:05 +00:00
pure ()
2021-08-30 20:41:58 +00:00
fromVersion :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
2021-05-14 21:09:45 +00:00
=> Maybe ToolVersion
2020-01-11 20:15:05 +00:00
-> Tool
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
2021-05-14 21:09:45 +00:00
fromVersion tv = fromVersion' (toSetToolVer tv)
2021-02-25 17:21:25 +00:00
2021-08-30 20:41:58 +00:00
fromVersion' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
2021-05-14 21:09:45 +00:00
=> SetToolVersion
2021-02-25 17:21:25 +00:00
-> Tool
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
2021-05-14 21:09:45 +00:00
fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
?? TagNotFound Recommended tool
2021-05-14 21:09:45 +00:00
fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
let vi = getVersionInfo (_tvVersion v) tool dls
2020-04-25 10:06:41 +00:00
case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi)
2020-04-22 14:13:58 +00:00
Right (PVP (major' :|[minor'])) ->
2021-05-14 21:09:45 +00:00
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi)
Right _ -> pure (v, vi)
2021-05-14 21:09:45 +00:00
fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-02-25 17:21:25 +00:00
next <- case tool of
GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
ghcs <- rights <$> lift getInstalledGHCs
(headMay
. tail
. dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
. cycle
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
. filter (\GHCTargetVersion {..} -> _tvTarget == Nothing)
$ ghcs) ?? NoToolVersionSet tool
Cabal -> do
set <- cabalSet !? NoToolVersionSet tool
cabals <- rights <$> lift getInstalledCabals
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ cabals) ?? NoToolVersionSet tool
HLS -> do
set <- hlsSet !? NoToolVersionSet tool
hlses <- rights <$> lift getInstalledHLSs
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ hlses) ?? NoToolVersionSet tool
2021-05-14 22:31:36 +00:00
Stack -> do
set <- stackSet !? NoToolVersionSet tool
stacks <- rights <$> lift getInstalledStacks
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ stacks) ?? NoToolVersionSet tool
2021-02-25 17:21:25 +00:00
GHCup -> fail "GHCup cannot be set"
2021-05-14 21:09:45 +00:00
let vi = getVersionInfo (_tvVersion next) tool dls
2021-02-25 17:21:25 +00:00
pure (next, vi)
2021-05-14 21:09:45 +00:00
fromVersion' (SetToolTag t') tool =
2020-04-22 00:33:35 +00:00
throwE $ TagNotFound t' tool
2020-01-11 20:15:05 +00:00
2020-04-22 10:30:02 +00:00
printListResult :: Bool -> [ListResult] -> IO ()
printListResult raw lr = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
let
color | raw || no_color = flip const
| otherwise = Pretty.color
let
printTag Recommended = color Green "recommended"
printTag Latest = color Yellow "latest"
printTag Prerelease = color Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag Old = ""
2020-01-11 20:15:05 +00:00
let
rows =
(\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
. fmap
2020-01-11 20:15:05 +00:00
(\ListResult {..} ->
2020-04-22 10:30:02 +00:00
let marks = if
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
| lSet -> (color Green "IS")
| lInstalled -> (color Green "I ")
| otherwise -> (color Red "X ")
#else
2020-04-22 10:30:02 +00:00
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
2021-05-14 21:09:45 +00:00
#endif
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
, intercalate ","
$ (if hlsPowered
then [color Green "hls-powered"]
else mempty
)
++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Yellow "stray"] else mempty)
++ (if lNoBindist
then [color Red "no-bindist"]
else mempty
)
]
2020-01-11 20:15:05 +00:00
)
$ lr
let cols =
foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
lengths = fmap maximum . (fmap . fmap) strWidth $ cols
padded = fmap (\xs -> zipWith padTo xs lengths) rows
forM_ padded $ \row -> putStrLn $ intercalate " " row
2020-04-22 00:33:35 +00:00
where
2020-03-09 21:21:22 +00:00
padTo str' x =
let lstr = strWidth str'
add' = x - lstr
in if add' < 0 then str' else str' ++ replicate add' ' '
-- | Calculate the render width of a string, considering
-- wide characters (counted as double width), ANSI escape codes
-- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width).
strWidth :: String -> Int
strWidth =
maximum
. (0 :)
. map (foldr (\a b -> charWidth a + b) 0)
. lines
. stripAnsi
-- | Strip ANSI escape sequences from a string.
--
-- >>> stripAnsi "\ESC[31m-1\ESC[m"
-- "-1"
stripAnsi :: String -> String
stripAnsi s' =
case
MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
of
Nothing -> error "Bad ansi escape" -- PARTIAL: should not happen
Just xs -> concat xs
where
-- This parses lots of invalid ANSI escape codes, but that should be fine
ansi =
MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
Void
String
Char
digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-- | Get the designated render width of a character: 0 for a combining
-- character, 1 for a regular character, 2 for a wide character.
-- (Wide characters are rendered as exactly double width in apps and
-- fonts that support it.) (From Pandoc.)
charWidth :: Char -> Int
charWidth c = case c of
_ | c < '\x0300' -> 1
| c >= '\x0300' && c <= '\x036F' -> 0
| -- combining
c >= '\x0370' && c <= '\x10FC' -> 1
| c >= '\x1100' && c <= '\x115F' -> 2
| c >= '\x1160' && c <= '\x11A2' -> 1
| c >= '\x11A3' && c <= '\x11A7' -> 2
| c >= '\x11A8' && c <= '\x11F9' -> 1
| c >= '\x11FA' && c <= '\x11FF' -> 2
| c >= '\x1200' && c <= '\x2328' -> 1
| c >= '\x2329' && c <= '\x232A' -> 2
| c >= '\x232B' && c <= '\x2E31' -> 1
| c >= '\x2E80' && c <= '\x303E' -> 2
| c == '\x303F' -> 1
| c >= '\x3041' && c <= '\x3247' -> 2
| c >= '\x3248' && c <= '\x324F' -> 1
| -- ambiguous
c >= '\x3250' && c <= '\x4DBF' -> 2
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
| c >= '\x4E00' && c <= '\xA4C6' -> 2
| c >= '\xA4D0' && c <= '\xA95F' -> 1
| c >= '\xA960' && c <= '\xA97C' -> 2
| c >= '\xA980' && c <= '\xABF9' -> 1
| c >= '\xAC00' && c <= '\xD7FB' -> 2
| c >= '\xD800' && c <= '\xDFFF' -> 1
| c >= '\xE000' && c <= '\xF8FF' -> 1
| -- ambiguous
c >= '\xF900' && c <= '\xFAFF' -> 2
| c >= '\xFB00' && c <= '\xFDFD' -> 1
| c >= '\xFE00' && c <= '\xFE0F' -> 1
| -- ambiguous
c >= '\xFE10' && c <= '\xFE19' -> 2
| c >= '\xFE20' && c <= '\xFE26' -> 1
| c >= '\xFE30' && c <= '\xFE6B' -> 2
| c >= '\xFE70' && c <= '\xFEFF' -> 1
| c >= '\xFF01' && c <= '\xFF60' -> 2
| c >= '\xFF61' && c <= '\x16A38' -> 1
| c >= '\x1B000' && c <= '\x1B001' -> 2
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
| c >= '\x1F200' && c <= '\x1F251' -> 2
| c >= '\x1F300' && c <= '\x1F773' -> 1
| c >= '\x20000' && c <= '\x3FFFD' -> 2
| otherwise -> 1
checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
2020-10-23 23:06:53 +00:00
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-10-23 23:06:53 +00:00
, MonadThrow m
, MonadIO m
, MonadFail m
)
2021-05-14 21:09:45 +00:00
=> m ()
checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
2021-05-14 21:09:45 +00:00
lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
forM_ (getLatest dls GHCup) $ \(l, _) -> do
2020-03-09 21:21:22 +00:00
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
2021-08-30 20:41:58 +00:00
$ logWarn $
2021-08-25 16:54:58 +00:00
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
2020-04-17 15:12:59 +00:00
forM_ (getLatest dls GHC) $ \(l, _) -> do
let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
2021-08-30 20:41:58 +00:00
$ logWarn $
2021-08-25 16:54:58 +00:00
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
forM_ (getLatest dls Cabal) $ \(l, _) -> do
let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
2021-08-30 20:41:58 +00:00
$ logWarn $
2021-08-25 16:54:58 +00:00
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
forM_ (getLatest dls HLS) $ \(l, _) -> do
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver ->
when (l > hls_ver)
2021-08-30 20:41:58 +00:00
$ logWarn $
2021-08-25 16:54:58 +00:00
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
2021-05-14 22:31:36 +00:00
forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver ->
when (l > stack_ver)
2021-08-30 20:41:58 +00:00
$ logWarn $
2021-08-25 16:54:58 +00:00
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"
2021-05-14 22:31:36 +00:00
2020-04-17 15:12:59 +00:00
prettyDebugInfo :: DebugInfo -> String
2021-08-25 16:54:58 +00:00
prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
"==========" <> "\n" <>
"GHCup base dir: " <> diBaseDir <> "\n" <>
"GHCup bin dir: " <> diBinDir <> "\n" <>
"GHCup GHC directory: " <> diGHCDir <> "\n" <>
"GHCup cache directory: " <> diCacheDir <> "\n" <>
"Architecture: " <> prettyShow diArch <> "\n" <>
"Platform: " <> prettyShow diPlatform <> "\n" <>
"Version: " <> describe_result
2020-04-17 16:26:55 +00:00