ghcup-hs/app/ghcup/Main.hs

1465 lines
48 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 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.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
#if !defined(TAR)
import Codec.Archive
#endif
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.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
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
2020-04-22 14:12:56 +00:00
import Data.List ( intercalate, sort )
2020-04-22 14:13:58 +00:00
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe
2020-01-11 20:15:05 +00:00
import Data.String.Interpolate
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
import HPath
import HPath.IO
2020-04-17 14:56:56 +00:00
import Language.Haskell.TH
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
2020-01-11 20:15:05 +00:00
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO hiding ( appendFile )
import Text.Read hiding ( lift )
2020-01-11 20:15:05 +00:00
import Text.Layout.Table
import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
2020-03-17 00:58:59 +00:00
import qualified Text.Megaparsec as MP
2020-01-11 20:15:05 +00:00
data Options = Options
{
-- global options
optVerbose :: Bool
, optCache :: Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Bool
2020-04-22 16:12:40 +00:00
, optKeepDirs :: KeepDirs
2020-04-29 17:12:58 +00:00
, optsDownloader :: Downloader
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
| Upgrade UpgradeOpts Bool
2020-04-10 15:36:27 +00:00
| ToolRequirements
| ChangeLog ChangeLogOptions
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
| Interactive
#endif
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
2020-04-25 10:06:41 +00:00
prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v'
2020-04-22 14:13:58 +00:00
prettyToolVer (ToolTag t) = show t
2020-01-11 20:15:05 +00:00
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
2020-01-11 20:15:05 +00:00
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
2020-01-11 20:15:05 +00:00
}
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
data SetOptions = SetOptions
{ sToolVer :: Maybe ToolVersion
2020-01-11 20:15:05 +00:00
}
data ListOptions = ListOptions
2020-04-22 10:30:02 +00:00
{ lTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
, lRawFormat :: Bool
2020-01-11 20:15:05 +00:00
}
data RmCommand = RmGHC RmOptions
| RmCabal 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
| CompileCabal CabalCompileOptions
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
data GHCCompileOptions = GHCCompileOptions
{ targetVer :: Version
, bootstrapGhc :: Either Version (Path Abs)
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
, patchDir :: Maybe (Path Abs)
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
}
data CabalCompileOptions = CabalCompileOptions
2020-01-11 20:15:05 +00:00
{ targetVer :: Version
, bootstrapGhc :: Either Version (Path Abs)
2020-01-11 20:15:05 +00:00
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
, patchDir :: Maybe (Path Abs)
2020-01-11 20:15:05 +00:00
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt (Path Abs)
| UpgradeGHCupDir
deriving Show
data ChangeLogOptions = ChangeLogOptions
{ clOpen :: Bool
, clTool :: Maybe Tool
, clToolVer :: Maybe ToolVersion
}
2020-01-11 20:15:05 +00:00
opts :: Parser Options
opts =
Options
<$> switch (short 'v' <> long "verbose" <> help "Enable verbosity")
2020-01-11 20:15:05 +00:00
<*> switch
(short 'c' <> long "cache" <> help "Cache downloads in ~/.ghcup/cache"
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
)
)
)
<*> switch
(short 'n' <> long "no-verify" <> help
2020-04-12 10:22:27 +00:00
"Skip tarball checksum verification"
2020-01-11 20:15:05 +00:00
)
2020-04-22 16:12:40 +00:00
<*> option
(eitherReader keepOnParser)
( long "keep"
<> metavar "<always|errors|never>"
<> help
2020-04-29 17:12:58 +00:00
"Keep build directories? (default: never)"
2020-04-22 16:12:40 +00:00
<> value Never
2020-04-29 17:12:58 +00:00
<> hidden
)
<*> option
(eitherReader downloaderParser)
( long "downloader"
#if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>"
<> help
"Downloader to use (default: internal)"
<> value Internal
#else
<> metavar "<curl|wget>"
<> help
"Downloader to use (default: curl)"
<> value Curl
#endif
<> hidden
2020-04-22 16:12:40 +00:00
)
2020-01-11 20:15:05 +00:00
<*> com
where
parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
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
<$> (info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal"
<> footerDoc (Just $ text installToolFooter)
)
)
2020-01-11 20:15:05 +00:00
)
<> command
"set"
((info
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
)
<> command
"rm"
((info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
)
2020-01-11 20:15:05 +00:00
<> command
"list"
((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
<$> (info (compileP <**> helper)
(progDesc "Compile a tool from source")
2020-01-11 20:15:05 +00:00
)
2020-03-09 21:21:22 +00:00
)
2020-01-11 20:15:05 +00:00
<> commandGroup "Main commands:"
)
<|> subparser
( command
"debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
2020-04-10 15:36:27 +00:00
<> command
"tool-requirements"
( (\_ -> ToolRequirements)
<$> (info (helper)
(progDesc "Show the requirements for ghc/cabal")
)
2020-04-10 15:36:27 +00:00
)
<> command
"changelog"
((info
(fmap ChangeLog changelogP <**> helper)
( progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
)
)
2020-01-11 20:15:05 +00:00
<> commandGroup "Other commands:"
<> hidden
)
<|> subparser
( command
"install-cabal"
((info
((InstallCabalLegacy <$> installOpts) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
<> internal
)
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.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
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).
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
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.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
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.|]
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
<$> (info
(installOpts <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
)
<> command
"cabal"
( InstallCabal
<$> (info
(installOpts <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
)
)
<|> (Right <$> installOpts)
where
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
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
2020-01-11 20:15:05 +00:00
installOpts :: Parser InstallOptions
installOpts =
(flip InstallOptions)
<$> (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"
)
)
)
<*> optional toolVersionArgument
2020-01-11 20:15:05 +00:00
setParser :: Parser (Either SetCommand SetOptions)
setParser =
(Left <$> subparser
( command
"ghc"
( SetGHC
<$> (info
(setOpts <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
)
)
<> command
"cabal"
( SetCabal
<$> (info
(setOpts <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
)
)
)
)
<|> (Right <$> setOpts)
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.|]
setOpts :: Parser SetOptions
setOpts = SetOptions <$> optional toolVersionArgument
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"
)
)
<*> (optional
(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"
(RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version")))
<> command
"cabal"
( RmCabal
<$> (info (versionParser' <**> helper)
(progDesc "Remove Cabal version")
)
)
)
)
<|> (Right <$> rmOpts)
2020-01-11 20:15:05 +00:00
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionArgument
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")
<*> (optional
(option
(eitherReader
(\s' -> case fmap toLower s' of
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
e -> Left $ e
)
)
(short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)"
)
)
)
<*> optional toolVersionArgument
2020-01-11 20:15:05 +00:00
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
<$> (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
)
)
<> command
"cabal"
( CompileCabal
<$> (info
2020-04-25 10:06:41 +00:00
(cabalCompileOpts <**> helper)
( progDesc "Compile Cabal from source"
<> footerDoc (Just $ text compileCabalFooter)
)
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:
ghcup compile ghc -j 4 -v 8.4.2 -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
compileCabalFooter = [i|Discussion:
Compiles and installs the specified Cabal version
into "~/.ghcup/bin".
Examples:
ghcup compile cabal -j 4 -v 3.2.0.0 -b 8.6.5
ghcup compile cabal -j 4 -v 3.2.0.0 -b /usr/bin/ghc-8.6.5|]
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts =
(\CabalCompileOptions {..} crossTarget addConfArgs -> GHCCompileOptions { .. }
)
<$> cabalCompileOpts
<*> (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)"))
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
cabalCompileOpts :: Parser CabalCompileOptions
cabalCompileOpts =
CabalCompileOptions
2020-01-11 20:15:05 +00:00
<$> (option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
)
<*> (option
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x)
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
)
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
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
)
)
<*> optional
(option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applied in order, uses -p1)"
)
)
2020-01-11 20:15:05 +00:00
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP <|> toolP
where
verP = ToolVersion <$> versionParser
toolP =
ToolTag
<$> (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 :: Parser ToolVersion
toolVersionArgument =
argument (eitherReader toolVersionEither) (metavar "VERSION|TAG")
2020-04-25 10:06:41 +00:00
versionArgument :: Parser GHCTargetVersion
versionArgument = argument (eitherReader tVersionEither) (metavar "VERSION")
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' :: Parser Version
versionParser' = argument
(eitherReader (bimap show id . version . T.pack))
(metavar "VERSION")
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)
Left _ -> Left [i|Invalid PVP version for base #{ver'}|]
other -> Left ([i|Unknown tag #{other}|])
2020-04-25 10:06:41 +00:00
tVersionEither :: String -> Either String GHCTargetVersion
tVersionEither =
bimap (const "Not a valid version") id . MP.parse ghcTargetVerP "" . T.pack
toolVersionEither :: String -> Either String ToolVersion
toolVersionEither s' =
2020-04-25 10:06:41 +00:00
bimap id ToolTag (tagEither s') <|> bimap id 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
2020-03-21 21:19:37 +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
]
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
verP suffix = do
ver <- parseUntil suffix
if T.null ver
then fail "empty version"
else do
rest <- MP.getInput
MP.setInput ver
v <- versioning'
MP.setInput rest
pure v
2020-04-25 10:06:41 +00:00
2020-03-17 00:58:59 +00:00
2020-01-11 20:15:05 +00:00
toSettings :: Options -> Settings
toSettings Options {..} =
2020-04-29 17:12:58 +00:00
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
2020-07-13 09:52:34 +00:00
verbose = optVerbose
2020-01-11 20:15:05 +00:00
in Settings { .. }
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
(short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
<$> (option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
)
<|> (pure UpgradeGHCupDir)
2020-04-17 14:56:56 +00:00
describe_result :: String
describe_result = $( (LitE . StringL) <$>
runIO (do
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe $ _stdOut
ExitFailure _ -> pure numericVer
)
)
2020-01-11 20:15:05 +00:00
main :: IO ()
main = do
2020-04-17 16:54:21 +00:00
let versionHelp = infoOption
( ("The GHCup Haskell installer, version " <>)
$ (head . lines $ describe_result)
)
2020-04-17 20:11:41 +00:00
(long "version" <> help "Show version" <> hidden)
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-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)
2020-04-22 18:12:57 +00:00
(info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> listCommands)
(footerDoc (Just $ text main_footer))
)
2020-01-11 20:15:05 +00:00
>>= \opt@Options {..} -> do
2020-04-22 16:12:40 +00:00
let settings@Settings{..} = toSettings opt
2020-01-11 20:15:05 +00:00
2020-03-17 18:16:21 +00:00
-- create ~/.ghcup dir
ghcdir <- ghcupBaseDir
createDirIfMissing newDirPerms ghcdir
2020-01-11 20:15:05 +00:00
-- logger interpreter
2020-03-16 09:47:09 +00:00
logfile <- initGHCupFileLogging [rel|ghcup.log|]
2020-07-06 20:39:16 +00:00
let loggerConfig = LoggerConfig
2020-01-11 20:15:05 +00:00
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
2020-07-06 20:39:16 +00:00
let runLogger = myLoggerT loggerConfig
2020-01-11 20:15:05 +00:00
-------------------------
-- Effect interpreters --
-------------------------
2020-01-11 20:15:05 +00:00
let runInstTool =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
2020-01-11 20:15:05 +00:00
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
]
2020-03-09 21:21:22 +00:00
let
runSetGHC =
runLogger
. flip runReaderT settings
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
]
2020-01-11 20:15:05 +00:00
let
runSetCabal =
runLogger
. runE
@'[ NotInstalled
, TagNotFound
]
2020-07-13 16:27:21 +00:00
let runListGHC = runLogger
2020-01-11 20:15:05 +00:00
2020-07-06 20:39:16 +00:00
let runRm =
2020-01-11 20:15:05 +00:00
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. flip runReaderT settings
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. flip runReaderT settings
. 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
#if !defined(TAR)
, ArchiveResult
#endif
2020-01-11 20:15:05 +00:00
]
let runCompileCabal =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, CopyError
2020-01-11 20:15:05 +00:00
, DigestError
2020-03-09 21:21:22 +00:00
, DownloadFailed
2020-04-10 17:27:17 +00:00
, NoDownload
, NotInstalled
2020-04-10 17:27:17 +00:00
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
2020-01-11 20:15:05 +00:00
]
let runUpgrade =
runLogger
. flip runReaderT settings
. 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
]
2020-07-13 16:27:21 +00:00
----------------------------------------
-- Getting download and platform info --
----------------------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) [i|Error determining Platform: #{e}|])
exitWith (ExitFailure 2)
2020-04-10 15:36:27 +00:00
(GHCupInfo treq dls) <-
2020-03-09 21:21:22 +00:00
( runLogger
. flip runReaderT settings
2020-04-27 21:23:34 +00:00
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
2020-03-17 17:39:01 +00:00
$ liftE
2020-04-27 21:23:34 +00:00
$ getDownloadsF (maybe GHCupURL OwnSource optUrlSource)
2020-03-09 21:21:22 +00:00
)
>>= \case
VRight r -> pure r
2020-04-17 16:54:21 +00:00
VLeft e -> do
2020-03-09 21:21:22 +00:00
runLogger
2020-04-17 16:54:21 +00:00
($(logError) [i|Error fetching download info: #{e}|])
2020-04-17 16:26:55 +00:00
exitWith (ExitFailure 2)
2020-07-13 16:27:21 +00:00
runLogger $ checkForUpdates dls pfreq
2020-01-11 20:15:05 +00:00
2020-04-22 14:13:58 +00:00
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
2020-07-13 16:27:21 +00:00
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("GHC installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available GHC version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended GHC version|]
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 3
let installCabal InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
2020-07-13 16:27:21 +00:00
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("Cabal installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available Cabal version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended Cabal version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
(runSetGHC $ do
v <- liftE $ fromVersion dls sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
runLogger
$ $(logInfo)
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 5
let setCabal' SetOptions{..} =
(runSetCabal $ do
v <- liftE $ fromVersion dls sToolVer Cabal
liftE $ setCabal (_tvVersion v)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
2020-07-06 20:39:16 +00:00
(runRm $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 7
let rmCabal' tv =
2020-07-06 20:39:16 +00:00
(runRm $ do
liftE $ rmCabalVer tv
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
res <- case optCommand of
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
2020-07-13 16:27:21 +00:00
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
2020-07-06 20:39:16 +00:00
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|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
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
installCabal iopts
Set (Right sopts) -> do
runLogger ($(logWarn) [i|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
2020-01-11 20:15:05 +00:00
List (ListOptions {..}) ->
2020-04-17 16:54:21 +00:00
(runListGHC $ do
2020-07-13 16:27:21 +00:00
l <- listVersions dls lTool lCriteria pfreq
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
runLogger ($(logWarn) [i|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
2020-01-11 20:15:05 +00:00
2020-04-17 16:54:21 +00:00
DInfo ->
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
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 8
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
Compile (CompileGHC GHCCompileOptions {..}) ->
2020-04-17 16:54:21 +00:00
(runCompileGHC $ liftE $ compileGHC dls
2020-04-25 10:06:41 +00:00
(GHCTargetVersion crossTarget targetVer)
2020-04-17 16:54:21 +00:00
bootstrapGhc
jobs
buildConfig
patchDir
2020-04-25 10:06:41 +00:00
addConfArgs
2020-07-13 16:27:21 +00:00
pfreq
2020-04-17 16:54:21 +00:00
)
2020-01-11 20:15:05 +00:00
>>= \case
2020-04-17 16:26:55 +00:00
VRight _ -> do
2020-01-11 20:15:05 +00:00
runLogger $ $(logInfo)
2020-03-21 21:19:37 +00:00
("GHC successfully compiled and installed")
2020-04-17 16:26:55 +00:00
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
2020-01-11 20:15:05 +00:00
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
2020-04-17 16:26:55 +00:00
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
2020-04-22 16:12:40 +00:00
case keepDirs of
2020-04-25 10:06:41 +00:00
Never -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs|])
2020-04-22 16:12:40 +00:00
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
2020-04-22 16:12:40 +00:00
Make sure to clean up #{tmpdir} afterwards.|])
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 9
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 9
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
Compile (CompileCabal CabalCompileOptions {..}) ->
2020-04-17 16:54:21 +00:00
(runCompileCabal $ do
2020-07-13 16:27:21 +00:00
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
2020-04-17 16:54:21 +00:00
)
2020-01-11 20:15:05 +00:00
>>= \case
2020-04-17 16:26:55 +00:00
VRight _ -> do
2020-04-17 16:54:21 +00:00
runLogger
($(logInfo)
"Cabal successfully compiled and installed"
)
2020-04-17 16:26:55 +00:00
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
2020-04-22 16:12:40 +00:00
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 10
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 10
2020-01-11 20:15:05 +00:00
Upgrade (uOpts) force -> do
2020-01-11 20:15:05 +00:00
target <- case uOpts of
UpgradeInplace -> do
efp <- liftIO $ getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do
bdir <- liftIO $ ghcupBinDir
2020-03-16 09:47:09 +00:00
pure (Just (bdir </> [rel|ghcup|]))
2020-01-11 20:15:05 +00:00
2020-07-13 16:27:21 +00:00
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
2020-04-17 16:54:21 +00:00
VRight v' -> do
let pretty_v = prettyVer v'
runLogger $ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) [i|No GHCup update available|]
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 11
ToolRequirements ->
( runLogger
$ runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
platform <- liftE $ getPlatform
req <-
(getCommonRequirements platform $ treq)
?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger
($(logError)
[i|Error getting tool requirements: #{e}|]
)
pure $ ExitFailure 12
2020-04-17 16:26:55 +00:00
ChangeLog (ChangeLogOptions {..}) -> do
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
($(logWarn)
[i|Could not find ChangeLog for #{tool}, version #{either (T.unpack . prettyVer) show ver'}|]
)
pure ExitSuccess
Just uri -> do
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"
if clOpen
then
2020-07-13 21:10:17 +00:00
exec cmd
True
[serializeURIRef' uri]
Nothing
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) [i|#{e}|])
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
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 ()
fromVersion :: Monad m
=> GHCupDownloads
-> Maybe ToolVersion
-> Tool
2020-04-25 10:06:41 +00:00
-> Excepts '[TagNotFound] m GHCTargetVersion
2020-01-11 20:15:05 +00:00
fromVersion av Nothing tool =
2020-04-25 10:06:41 +00:00
mkTVer <$> getRecommended av tool ?? TagNotFound Recommended tool
2020-04-22 14:13:58 +00:00
fromVersion av (Just (ToolVersion v)) _ = do
2020-04-25 10:06:41 +00:00
case pvp $ prettyVer (_tvVersion v) of
2020-04-22 14:13:58 +00:00
Left _ -> pure v
Right (PVP (major' :|[minor'])) ->
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of
2020-04-25 10:06:41 +00:00
Just v' -> pure $ GHCTargetVersion (_tvTarget v) v'
2020-04-22 14:13:58 +00:00
Nothing -> pure v
Right _ -> pure v
2020-01-11 20:15:05 +00:00
fromVersion av (Just (ToolTag Latest)) tool =
2020-04-25 10:06:41 +00:00
mkTVer <$> getLatest av tool ?? TagNotFound Latest tool
2020-01-11 20:15:05 +00:00
fromVersion av (Just (ToolTag Recommended)) tool =
2020-04-25 10:06:41 +00:00
mkTVer <$> getRecommended av tool ?? TagNotFound Recommended tool
2020-04-22 00:33:35 +00:00
fromVersion av (Just (ToolTag (Base pvp''))) GHC =
2020-04-25 10:06:41 +00:00
mkTVer <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC
2020-04-22 00:33:35 +00:00
fromVersion _ (Just (ToolTag t')) tool =
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
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
2020-01-11 20:15:05 +00:00
let
formatted =
gridString
2020-04-22 10:30:02 +00:00
( (if raw then [] else [column expand left def def])
++ [ column expand left def def
, column expand left def def
, column expand left def def
, column expand left def def
]
)
. (\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
2020-01-11 20:15:05 +00:00
$ fmap
(\ListResult {..} ->
2020-04-22 10:30:02 +00:00
let marks = if
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
in (if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
2020-04-25 10:06:41 +00:00
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
2020-04-22 14:12:56 +00:00
, intercalate "," $ (fmap printTag $ sort lTag)
2020-04-22 10:30:02 +00:00
, intercalate ","
$ (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-04-22 10:30:02 +00:00
]
2020-01-11 20:15:05 +00:00
)
lr
putStrLn $ formatted
2020-04-22 00:33:35 +00:00
where
2020-04-22 10:30:02 +00:00
printTag Recommended = color' Green "recommended"
printTag Latest = color' Yellow "latest"
2020-04-22 14:12:56 +00:00
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
2020-04-22 10:30:02 +00:00
printTag (UnknownTag t ) = t
color' = case raw of
True -> flip const
False -> color
2020-03-09 21:21:22 +00:00
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
2020-07-13 16:27:21 +00:00
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
2020-03-09 21:21:22 +00:00
forM_ (getLatest dls GHCup) $ \l -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
2020-07-13 16:27:21 +00:00
$ $(logWarn)
2020-03-09 21:21:22 +00:00
[i|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
mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
2020-07-13 16:27:21 +00:00
$ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
2020-07-13 16:27:21 +00:00
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
2020-07-13 16:27:21 +00:00
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
2020-04-17 15:12:59 +00:00
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info
==========
GHCup base dir: #{toFilePath diBaseDir}
GHCup bin dir: #{toFilePath diBinDir}
GHCup GHC directory: #{toFilePath diGHCDir}
GHCup cache directory: #{toFilePath diCacheDir}
Architecture: #{prettyArch diArch}
Platform: #{prettyPlatform diPlatform}
Version: #{describe_result}|]
where
prettyArch :: Architecture -> String
prettyArch A_64 = "amd64"
prettyArch A_32 = "i386"
2020-06-27 17:00:13 +00:00
prettyArch A_PowerPC = "PowerPC"
prettyArch A_PowerPC64 = "PowerPC64"
prettyArch A_Sparc = "Sparc"
prettyArch A_Sparc64 = "Sparc64"
prettyArch A_ARM = "ARM"
prettyArch A_ARM64 = "ARM64"
2020-04-17 15:12:59 +00:00
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat
2020-04-17 16:26:55 +00:00