{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} module Main where #if defined(BRICK) import BrickMain ( brickMain ) #endif import GHCup import GHCup.Download import GHCup.Errors import GHCup.Platform import GHCup.Requirements import GHCup.Types import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude import GHCup.Utils.String.QQ import GHCup.Version import Codec.Archive import Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Bifunctor import Data.Char import Data.Either import Data.Functor import Data.List ( intercalate, sort ) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Maybe import Data.String.Interpolate import Data.Text ( Text ) import Data.Versions hiding ( str ) import Data.Void import GHC.IO.Encoding import Haskus.Utils.Variant.Excepts import HPath import HPath.IO import Language.Haskell.TH import Options.Applicative hiding ( style ) import Options.Applicative.Help.Pretty ( text ) import Prelude hiding ( appendFile ) import Safe import System.Console.Pretty import System.Environment import System.Exit import System.IO hiding ( appendFile ) import Text.Read hiding ( lift ) 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 import qualified Text.Megaparsec as MP data Options = Options { -- global options optVerbose :: Bool , optCache :: Bool , optUrlSource :: Maybe URI , optNoVerify :: Bool , optKeepDirs :: KeepDirs , optsDownloader :: Downloader -- commands , optCommand :: Command } data Command = Install (Either InstallCommand InstallOptions) | InstallCabalLegacy InstallOptions | Set (Either SetCommand SetOptions) | List ListOptions | Rm (Either RmCommand RmOptions) | DInfo | Compile CompileCommand | Upgrade UpgradeOpts Bool | ToolRequirements | ChangeLog ChangeLogOptions #if defined(BRICK) | Interactive #endif data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal | ToolTag Tag prettyToolVer :: ToolVersion -> String prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v' prettyToolVer (ToolTag t) = show t data InstallCommand = InstallGHC InstallOptions | InstallCabal InstallOptions data InstallOptions = InstallOptions { instVer :: Maybe ToolVersion , instPlatform :: Maybe PlatformRequest } data SetCommand = SetGHC SetOptions | SetCabal SetOptions data SetOptions = SetOptions { sToolVer :: Maybe ToolVersion } data ListOptions = ListOptions { lTool :: Maybe Tool , lCriteria :: Maybe ListCriteria , lRawFormat :: Bool } data RmCommand = RmGHC RmOptions | RmCabal Version data RmOptions = RmOptions { ghcVer :: GHCTargetVersion } data CompileCommand = CompileGHC GHCCompileOptions | CompileCabal CabalCompileOptions 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 { targetVer :: Version , bootstrapGhc :: Either Version (Path Abs) , jobs :: Maybe Int , buildConfig :: Maybe (Path Abs) , patchDir :: Maybe (Path Abs) } data UpgradeOpts = UpgradeInplace | UpgradeAt (Path Abs) | UpgradeGHCupDir deriving Show data ChangeLogOptions = ChangeLogOptions { clOpen :: Bool , clTool :: Maybe Tool , clToolVer :: Maybe ToolVersion } opts :: Parser Options opts = Options <$> switch (short 'v' <> long "verbose" <> help "Enable verbosity") <*> switch (short 'c' <> long "cache" <> help "Cache downloads in ~/.ghcup/cache" ) <*> (optional (option (eitherReader parseUri) ( short 's' <> long "url-source" <> metavar "URL" <> help "Alternative ghcup download info url" <> internal ) ) ) <*> switch (short 'n' <> long "no-verify" <> help "Skip tarball checksum verification" ) <*> option (eitherReader keepOnParser) ( long "keep" <> metavar "" <> help "Keep build directories? (default: never)" <> value Never <> hidden ) <*> option (eitherReader downloaderParser) ( long "downloader" #if defined(INTERNAL_DOWNLOADER) <> metavar "" <> help "Downloader to use (default: internal)" <> value Internal #else <> metavar "" <> help "Downloader to use (default: curl)" <> value Curl #endif <> hidden ) <*> com where parseUri s' = bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s') com :: Parser Command com = subparser #if defined(BRICK) ( command "tui" ( (\_ -> Interactive) <$> (info helper ( progDesc "Start the interactive GHCup UI" ) ) ) <> command #else ( command #endif "install" ( Install <$> (info (installParser <**> helper) ( progDesc "Install or update GHC/cabal" <> footerDoc (Just $ text installToolFooter) ) ) ) <> 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) ) ) ) <> command "list" ((info (List <$> listOpts <**> helper) (progDesc "Show available GHCs and other tools") ) ) <> command "upgrade" (info ( (Upgrade <$> upgradeOptsP <*> switch (short 'f' <> long "force" <> help "Force update") ) <**> helper ) (progDesc "Upgrade ghcup") ) <> command "compile" ( Compile <$> (info (compileP <**> helper) (progDesc "Compile a tool from source") ) ) <> commandGroup "Main commands:" ) <|> subparser ( command "debug-info" ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info"))) <> command "tool-requirements" ( (\_ -> ToolRequirements) <$> (info (helper) (progDesc "Show the requirements for ghc/cabal") ) ) <> command "changelog" ((info (fmap ChangeLog changelogP <**> helper) ( progDesc "Find/show changelog" <> footerDoc (Just $ text changeLogFooter) ) ) ) <> commandGroup "Other commands:" <> hidden ) <|> subparser ( command "install-cabal" ((info ((InstallCabalLegacy <$> installOpts) <**> helper) ( progDesc "Install or update cabal" <> footerDoc (Just $ text installCabalFooter) ) ) ) <> internal ) where installToolFooter :: String 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 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 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 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 installCabalFooter = [s|Discussion: 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 installGHCFooter = [s|Discussion: Installs the specified GHC version (or a recommended default one) into a self-contained "~/.ghcup/ghc/" directory and symlinks the ghc binaries to "~/.ghcup/bin/-".|] 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 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 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/".|] setCabalFooter :: String setCabalFooter = [s|Discussion: Sets the the current Cabal version.|] setOpts :: Parser SetOptions setOpts = SetOptions <$> optional toolVersionArgument listOpts :: Parser ListOptions listOpts = ListOptions <$> optional (option (eitherReader toolParser) (short 't' <> long "tool" <> metavar "" <> help "Tool to list versions for. Default is all" ) ) <*> (optional (option (eitherReader criteriaParser) ( short 'c' <> long "show-criteria" <> metavar "" <> help "Show only installed or set tool versions" ) ) ) <*> switch (short 'r' <> long "raw-format" <> help "More machine-parsable format" ) 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) rmOpts :: Parser RmOptions rmOpts = RmOptions <$> versionArgument 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 "" <> help "Open changelog for given tool (default: ghc)" ) ) ) <*> optional toolVersionArgument compileP :: Parser CompileCommand compileP = subparser ( command "ghc" ( CompileGHC <$> (info (ghcCompileOpts <**> helper) ( progDesc "Compile GHC from source" <> footerDoc (Just $ text compileFooter) ) ) ) <> command "cabal" ( CompileCabal <$> (info (cabalCompileOpts <**> helper) ( progDesc "Compile Cabal from source" <> footerDoc (Just $ text compileCabalFooter) ) ) ) ) where compileFooter = [s|Discussion: Compiles and installs the specified GHC version into a self-contained "~/.ghcup/ghc/" directory and symlinks the ghc binaries to "~/.ghcup/bin/-". This also allows building a cross-compiler. Consult the documentation first: ENV variables: Various toolchain variables will be passed onto the ghc build system, such as: CC, LD, OBJDUMP, NM, AR, RANLIB. Examples: ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 # 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|] 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|] 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)")) cabalCompileOpts :: Parser CabalCompileOptions cabalCompileOpts = CabalCompileOptions <$> (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) ) ) ( short 'b' <> long "bootstrap-ghc" <> metavar "BOOTSTRAP_GHC" <> help "The GHC version (or full path) to bootstrap with (must be installed)" ) ) <*> 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)" ) ) toolVersionParser :: Parser ToolVersion toolVersionParser = verP <|> toolP where verP = ToolVersion <$> versionParser toolP = ToolTag <$> (option (eitherReader tagEither) (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") versionArgument :: Parser GHCTargetVersion versionArgument = argument (eitherReader tVersionEither) (metavar "VERSION") versionParser :: Parser GHCTargetVersion versionParser = option (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 ('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}|]) 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' = bimap id ToolTag (tagEither s') <|> bimap id ToolVersion (tVersionEither s') 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') keepOnParser :: String -> Either String KeepDirs keepOnParser s' | t == T.pack "always" = Right Always | t == T.pack "errors" = Right Errors | t == T.pack "never" = Right Never | otherwise = Left ("Unknown keep value: " <> s') where t = T.toLower (T.pack s') downloaderParser :: String -> Either String Downloader downloaderParser s' | t == T.pack "curl" = Right Curl | t == T.pack "wget" = Right Wget #if defined(INTERNAL_DOWNLOADER) | t == T.pack "internal" = Right Internal #endif | otherwise = Left ("Unknown downloader value: " <> s') where t = T.toLower (T.pack s') platformParser :: String -> Either String PlatformRequest platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of Right r -> pure r Left e -> Left $ errorBundlePretty e where archP :: MP.Parsec Void Text Architecture archP = (MP.try (MP.chunk "x86_64" $> A_64)) <|> (MP.chunk "i386" $> A_32) platformP :: MP.Parsec Void Text PlatformRequest platformP = choice' [ (\a mv -> PlatformRequest a FreeBSD mv) <$> (archP <* MP.chunk "-") <*> ( MP.chunk "portbld" *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) <|> pure Nothing ) <* MP.chunk "-freebsd" ) , (\a mv -> PlatformRequest a Darwin mv) <$> (archP <* MP.chunk "-") <*> ( MP.chunk "apple" *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) <|> pure Nothing ) <* MP.chunk "-darwin" ) , (\a d mv -> PlatformRequest a (Linux d) mv) <$> (archP <* MP.chunk "-") <*> distroP <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing ) <* MP.chunk "-linux" ) ] distroP :: MP.Parsec Void Text LinuxDistro distroP = choice' [ 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 ] 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 toSettings :: Options -> Settings toSettings Options {..} = let cache = optCache noVerify = optNoVerify keepDirs = optKeepDirs downloader = optsDownloader 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) 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 ) ) main :: IO () main = do let versionHelp = infoOption ( ("The GHCup Haskell installer, version " <>) $ (head . lines $ describe_result) ) (long "version" <> help "Show version" <> hidden) let numericVersionHelp = infoOption numericVer ( long "numeric-version" <> help "Show the numeric version (for use in scripts)" <> hidden ) 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 ) let main_footer = [s|Discussion: ghcup installs the Glasgow Haskell Compiler from the official release channels, enabling you to easily switch between different 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) Report bugs at |] customExecParser (prefs showHelpOnError) (info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> listCommands) (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do let settings@Settings{..} = toSettings opt -- create ~/.ghcup dir ghcdir <- ghcupBaseDir createDirIfMissing newDirPerms ghcdir -- logger interpreter logfile <- initGHCupFileLogging [rel|ghcup.log|] let loggerConfig = LoggerConfig { lcPrintDebug = optVerbose , colorOutter = B.hPut stderr , rawOutter = appendFile logfile } let runLogger = myLoggerT loggerConfig ------------------------- -- Effect interpreters -- ------------------------- let runInstTool = runLogger . flip runReaderT settings . runResourceT . runE @'[ AlreadyInstalled , UnknownArchive , ArchiveResult , DistroNotFound , FileDoesNotExistError , CopyError , NoCompatibleArch , NoDownload , NotInstalled , NoCompatiblePlatform , BuildFailed , TagNotFound , DigestError , DownloadFailed ] let runSetGHC = runLogger . flip runReaderT settings . runE @'[ FileDoesNotExistError , NotInstalled , TagNotFound ] let runSetCabal = runLogger . runE @'[ NotInstalled , TagNotFound ] let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] let runRm = 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 , DistroNotFound , DownloadFailed , GHCupSetError , NoCompatibleArch , NoCompatiblePlatform , NoDownload , NotFoundInPATH , PatchFailed , UnknownArchive , ArchiveResult ] let runCompileCabal = runLogger . flip runReaderT settings . runResourceT . runE @'[ AlreadyInstalled , BuildFailed , CopyError , DigestError , DistroNotFound , DownloadFailed , NoCompatibleArch , NoCompatiblePlatform , NoDownload , NotInstalled , PatchFailed , UnknownArchive , ArchiveResult ] let runUpgrade = runLogger . flip runReaderT settings . runResourceT . runE @'[ DigestError , DistroNotFound , NoCompatiblePlatform , NoCompatibleArch , NoDownload , NoUpdate , FileDoesNotExistError , CopyError , DownloadFailed ] --------------------------- -- Getting download info -- --------------------------- (GHCupInfo treq dls) <- ( runLogger . flip runReaderT settings . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE $ getDownloadsF (maybe GHCupURL OwnSource optUrlSource) ) >>= \case VRight r -> pure r VLeft e -> do runLogger ($(logError) [i|Error fetching download info: #{e}|]) exitWith (ExitFailure 2) (runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls ) >>= \case VRight _ -> pure () VLeft e -> do runLogger ($(logError) [i|Error checking for upgrades: #{e}|]) ----------------------- -- Command functions -- ----------------------- let installGHC InstallOptions{..} = (runInstTool $ do v <- liftE $ fromVersion dls instVer GHC liftE $ installGHCBin dls (_tvVersion v) 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 liftE $ installCabalBin dls (_tvVersion v) 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{..} = (runRm $ do liftE $ rmGHCVer ghcVer ) >>= \case VRight _ -> pure ExitSuccess VLeft e -> do runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 7 let rmCabal' tv = (runRm $ do liftE $ rmCabalVer tv ) >>= \case VRight _ -> pure ExitSuccess VLeft e -> do runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 15 res <- case optCommand of #if defined(BRICK) Interactive -> liftIO $ brickMain loggerConfig >> pure ExitSuccess #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 List (ListOptions {..}) -> (runListGHC $ do l <- listVersions dls lTool lCriteria pure l ) >>= \case VRight r -> do liftIO $ printListResult lRawFormat r pure ExitSuccess VLeft e -> do runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 6 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 DInfo -> do (runDebugInfo $ liftE $ getDebugInfo) >>= \case VRight dinfo -> do putStrLn $ prettyDebugInfo dinfo pure ExitSuccess VLeft e -> do runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 8 Compile (CompileGHC GHCCompileOptions {..}) -> (runCompileGHC $ liftE $ compileGHC dls (GHCTargetVersion crossTarget targetVer) bootstrapGhc jobs buildConfig patchDir addConfArgs ) >>= \case VRight _ -> do runLogger $ $(logInfo) ("GHC successfully compiled and installed") 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} Check the logs at ~/.ghcup/logs|]) _ -> 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 9 VLeft e -> do runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 9 Compile (CompileCabal CabalCompileOptions {..}) -> (runCompileCabal $ do liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir ) >>= \case VRight _ -> do runLogger ($(logInfo) "Cabal successfully compiled and 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 10 VLeft e -> do runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 10 Upgrade (uOpts) force -> do 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 pure (Just (bdir [rel|ghcup|])) (runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case 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 ChangeLog (ChangeLogOptions {..}) -> do let tool = fromMaybe GHC clTool ver' = maybe (Right Latest) (\case 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 if clOpen then exec "xdg-open" True [serializeURIRef' uri] Nothing Nothing >>= \case Right _ -> pure ExitSuccess Left e -> runLogger ($(logError) [i|#{e}|]) >> pure (ExitFailure 13) else putStrLn uri' >> pure ExitSuccess case res of ExitSuccess -> pure () ef@(ExitFailure _) -> exitWith ef pure () fromVersion :: Monad m => GHCupDownloads -> Maybe ToolVersion -> Tool -> Excepts '[TagNotFound] m GHCTargetVersion fromVersion av Nothing tool = mkTVer <$> getRecommended av tool ?? TagNotFound Recommended tool fromVersion av (Just (ToolVersion v)) _ = do case pvp $ prettyVer (_tvVersion v) of Left _ -> pure v Right (PVP (major' :|[minor'])) -> case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of Just v' -> pure $ GHCTargetVersion (_tvTarget v) v' Nothing -> pure v Right _ -> pure v fromVersion av (Just (ToolTag Latest)) tool = mkTVer <$> getLatest av tool ?? TagNotFound Latest tool fromVersion av (Just (ToolTag Recommended)) tool = mkTVer <$> getRecommended av tool ?? TagNotFound Recommended tool fromVersion av (Just (ToolTag (Base pvp''))) GHC = mkTVer <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC fromVersion _ (Just (ToolTag t')) tool = throwE $ TagNotFound t' tool printListResult :: Bool -> [ListResult] -> IO () printListResult raw lr = do -- https://gitlab.haskell.org/ghc/ghc/issues/8118 setLocaleEncoding utf8 let formatted = gridString ( (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 ) $ fmap (\ListResult {..} -> let marks = if | lSet -> (color Green "✔✔") | lInstalled -> (color Green "✓") | otherwise -> (color Red "✗") 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 "," $ (fmap printTag $ sort lTag) , 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) ] ) lr putStrLn $ formatted where printTag Recommended = color' Green "recommended" printTag Latest = color' Yellow "latest" printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') printTag (UnknownTag t ) = t color' = case raw of True -> flip const False -> color checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) => GHCupDownloads -> Excepts '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ] m () checkForUpdates dls = do forM_ (getLatest dls GHCup) $ \l -> do (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer when (l > ghc_ver) $ lift $ $(logWarn) [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|] forM_ (getLatest dls GHC) $ \l -> do mghc_ver <- latestInstalled GHC forM mghc_ver $ \ghc_ver -> when (l > ghc_ver) $ lift $ $(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) $ lift $ $(logWarn) [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|] where latestInstalled tool = (fmap lVer . lastMay) <$> (listVersions dls (Just tool) (Just ListInstalled)) 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" prettyArch A_PowerPC = "PowerPC" prettyArch A_PowerPC64 = "PowerPC64" prettyArch A_Sparc = "Sparc" prettyArch A_Sparc64 = "Sparc64" prettyArch A_ARM = "ARM" prettyArch A_ARM64 = "ARM64" prettyPlatform :: PlatformResult -> String prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' } = show plat <> ", " <> show v' prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing } = show plat