From 01956d694d9a7c109238ace40dca676e96ce3bf1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 15 Oct 2021 22:24:23 +0200 Subject: [PATCH] Refactor app Main --- .gitignore | 2 + .gitlab/script/hlint.sh | 2 +- app/ghcup-gen/Main.hs | 3 - app/ghcup-gen/Validate.hs | 26 +- app/ghcup/BrickMain.hs | 21 +- app/ghcup/GHCup/OptParse.hs | 303 ++ app/ghcup/GHCup/OptParse/ChangeLog.hs | 150 + app/ghcup/GHCup/OptParse/Common.hs | 513 ++++ app/ghcup/GHCup/OptParse/Compile.hs | 517 ++++ app/ghcup/GHCup/OptParse/Config.hs | 168 + app/ghcup/GHCup/OptParse/DInfo.hs | 119 + app/ghcup/GHCup/OptParse/GC.hs | 143 + app/ghcup/GHCup/OptParse/Install.hs | 464 +++ app/ghcup/GHCup/OptParse/List.hs | 268 ++ app/ghcup/GHCup/OptParse/Nuke.hs | 99 + app/ghcup/GHCup/OptParse/Prefetch.hs | 219 ++ app/ghcup/GHCup/OptParse/Rm.hs | 232 ++ app/ghcup/GHCup/OptParse/Set.hs | 349 +++ app/ghcup/GHCup/OptParse/ToolRequirements.hs | 82 + app/ghcup/GHCup/OptParse/UnSet.hs | 205 ++ app/ghcup/GHCup/OptParse/Upgrade.hs | 150 + app/ghcup/GHCup/OptParse/Whereis.hs | 319 ++ app/ghcup/Main.hs | 2879 +----------------- ghcup.cabal | 17 + 24 files changed, 4370 insertions(+), 2880 deletions(-) create mode 100644 app/ghcup/GHCup/OptParse.hs create mode 100644 app/ghcup/GHCup/OptParse/ChangeLog.hs create mode 100644 app/ghcup/GHCup/OptParse/Common.hs create mode 100644 app/ghcup/GHCup/OptParse/Compile.hs create mode 100644 app/ghcup/GHCup/OptParse/Config.hs create mode 100644 app/ghcup/GHCup/OptParse/DInfo.hs create mode 100644 app/ghcup/GHCup/OptParse/GC.hs create mode 100644 app/ghcup/GHCup/OptParse/Install.hs create mode 100644 app/ghcup/GHCup/OptParse/List.hs create mode 100644 app/ghcup/GHCup/OptParse/Nuke.hs create mode 100644 app/ghcup/GHCup/OptParse/Prefetch.hs create mode 100644 app/ghcup/GHCup/OptParse/Rm.hs create mode 100644 app/ghcup/GHCup/OptParse/Set.hs create mode 100644 app/ghcup/GHCup/OptParse/ToolRequirements.hs create mode 100644 app/ghcup/GHCup/OptParse/UnSet.hs create mode 100644 app/ghcup/GHCup/OptParse/Upgrade.hs create mode 100644 app/ghcup/GHCup/OptParse/Whereis.hs diff --git a/.gitignore b/.gitignore index 7e8c03c..a1e3592 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,5 @@ TAGS /tmp/ .entangled release/ +releases/ +site/ diff --git a/.gitlab/script/hlint.sh b/.gitlab/script/hlint.sh index be93b31..54d31e6 100755 --- a/.gitlab/script/hlint.sh +++ b/.gitlab/script/hlint.sh @@ -15,5 +15,5 @@ git describe ecabal update ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint -hlint -r lib/ test/ +hlint -r app/ lib/ test/ diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 6a9369e..f28b626 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 3e949e9..91bb612 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -91,23 +91,23 @@ validate dls _ = do checkHasRequiredPlatforms t v tags arch pspecs = do let v' = prettyVer v arch' = prettyShow arch - when (notElem (Linux UnknownLinux) pspecs) $ do + when (Linux UnknownLinux `notElem` pspecs) $ do lift $ logError $ "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' addError - when ((notElem Darwin pspecs) && arch == A_64) $ do + when ((Darwin `notElem` pspecs) && arch == A_64) $ do lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' addError - when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $ + when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $ "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' - when (notElem Windows pspecs && arch == A_64) $ do + when (Windows `notElem` pspecs && arch == A_64) $ do lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' addError -- alpine needs to be set explicitly, because -- we cannot assume that "Linux UnknownLinux" runs on Alpine -- (although it could be static) - when (notElem (Linux Alpine) pspecs) $ + when (Linux Alpine `notElem` pspecs) $ case t of GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError Cabal | v > [vver|2.4.1.0|] @@ -117,7 +117,7 @@ validate dls _ = do _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch) checkUniqueTags tool = do - let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool + let allTags = _viTags =<< M.elems (availableToolVersions dls tool) let nonUnique = fmap fst . filter (\(_, b) -> not b) @@ -155,8 +155,8 @@ validate dls _ = do -- a tool must have at least one of each mandatory tags checkMandatoryTags tool = do - let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool - forM_ [Latest, Recommended] $ \t -> case elem t allTags of + let allTags = _viTags =<< M.elems (availableToolVersions dls tool) + forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of False -> do lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool) addError @@ -202,7 +202,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool let gdlis = nubOrd $ gt ^.. each let allDls = either (const gdlis) (const dlis) etool - when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError) + when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref forM_ allDls (downloadAll ref) -- exit @@ -260,7 +260,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do when (basePath /= prel) $ do logError $ "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath - (flip runReaderT ref addError) + runReaderT addError ref Just (RegexDir regexString) -> do logInfo $ "verifying subdir (regex): " <> T.pack regexString @@ -268,13 +268,13 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do compIgnoreCase execBlank regexString - when (not (match regex basePath)) $ do + unless (match regex basePath) $ do logError $ "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath - (flip runReaderT ref addError) + runReaderT addError ref Nothing -> pure () VRight Nothing -> pure () VLeft e -> do logError $ "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e) - (flip runReaderT ref addError) + runReaderT addError ref diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 85b9d3f..f20428e 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -2,10 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} module BrickMain where @@ -368,10 +365,7 @@ listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix selectLatest :: Vector ListResult -> Int -selectLatest v = - case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of - Just ix -> ix - Nothing -> 0 +selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) -- | Replace the @appState@ or construct it based on a filter function @@ -398,14 +392,14 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool filterVisible v t e | lInstalled e = True | v , not t - , not (elem (lTool e) hiddenTools) = True + , lTool e `notElem` hiddenTools = True | not v , t - , not (elem Old (lTag e)) = True + , Old `notElem` lTag e = True | v , t = True - | otherwise = not (elem Old (lTag e)) && - not (elem (lTool e) hiddenTools) + | otherwise = (Old `notElem` lTag e) && + (lTool e `notElem` hiddenTools) install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) @@ -507,7 +501,7 @@ del' _ (_, ListResult {..}) = do ) >>= \case VRight vi -> do - forM_ (join $ fmap _viPostRemove vi) $ \msg -> + forM_ (_viPostRemove =<< vi) $ \msg -> logInfo msg pure $ Right () VLeft e -> pure $ Left (prettyShow e) @@ -594,8 +588,7 @@ getGHCupInfo = do r <- flip runReaderT settings . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] - $ liftE - $ getDownloadsF + $ liftE getDownloadsF case r of VRight a -> pure $ Right a diff --git a/app/ghcup/GHCup/OptParse.hs b/app/ghcup/GHCup/OptParse.hs new file mode 100644 index 0000000..1d01312 --- /dev/null +++ b/app/ghcup/GHCup/OptParse.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} + + +module GHCup.OptParse ( + module GHCup.OptParse.Common + , module GHCup.OptParse.Install + , module GHCup.OptParse.Set + , module GHCup.OptParse.UnSet + , module GHCup.OptParse.Rm + , module GHCup.OptParse.Compile + , module GHCup.OptParse.Config + , module GHCup.OptParse.Whereis + , module GHCup.OptParse.List + , module GHCup.OptParse.Upgrade + , module GHCup.OptParse.ChangeLog + , module GHCup.OptParse.Prefetch + , module GHCup.OptParse.GC + , module GHCup.OptParse.DInfo + , module GHCup.OptParse.Nuke + , module GHCup.OptParse.ToolRequirements + , module GHCup.OptParse +) where + + +import GHCup.OptParse.Common +import GHCup.OptParse.Install +import GHCup.OptParse.Set +import GHCup.OptParse.UnSet +import GHCup.OptParse.Rm +import GHCup.OptParse.Compile +import GHCup.OptParse.Config +import GHCup.OptParse.Whereis +import GHCup.OptParse.List +import GHCup.OptParse.Upgrade +import GHCup.OptParse.ChangeLog +import GHCup.OptParse.Prefetch +import GHCup.OptParse.GC +import GHCup.OptParse.DInfo +import GHCup.OptParse.ToolRequirements +import GHCup.OptParse.Nuke + +import GHCup.Types + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Bifunctor +import Data.Either +import Data.Functor +import Data.Maybe +import Options.Applicative hiding ( style ) +import Options.Applicative.Help.Pretty ( text ) +import Prelude hiding ( appendFile ) +import URI.ByteString + +import qualified Data.ByteString.UTF8 as UTF8 + + + +data Options = Options + { + -- global options + optVerbose :: Maybe Bool + , optCache :: Maybe Bool + , optUrlSource :: Maybe URI + , optNoVerify :: Maybe Bool + , optKeepDirs :: Maybe KeepDirs + , optsDownloader :: Maybe Downloader + , optNoNetwork :: Maybe Bool + , optGpg :: Maybe GPGSetting + -- commands + , optCommand :: Command + } + +data Command + = Install (Either InstallCommand InstallOptions) + | InstallCabalLegacy InstallOptions + | Set (Either SetCommand SetOptions) + | UnSet UnsetCommand + | List ListOptions + | Rm (Either RmCommand RmOptions) + | DInfo + | Compile CompileCommand + | Config ConfigCommand + | Whereis WhereisOptions WhereisCommand + | Upgrade UpgradeOpts Bool + | ToolRequirements + | ChangeLog ChangeLogOptions + | Nuke +#if defined(BRICK) + | Interactive +#endif + | Prefetch PrefetchCommand + | GC GCOptions + + + +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)") + <*> optional + (option + (eitherReader parseUri) + ( short 's' + <> long "url-source" + <> metavar "URL" + <> help "Alternative ghcup download info url" + <> internal + ) + ) + <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)")) + <*> optional (option + (eitherReader keepOnParser) + ( long "keep" + <> metavar "" + <> help + "Keep build directories? (default: errors)" + <> hidden + )) + <*> optional (option + (eitherReader downloaderParser) + ( long "downloader" +#if defined(INTERNAL_DOWNLOADER) + <> metavar "" + <> help + "Downloader to use (default: internal)" +#else + <> metavar "" + <> help + "Downloader to use (default: curl)" +#endif + <> hidden + )) + <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.") + <*> optional (option + (eitherReader gpgParser) + ( long "gpg" + <> metavar "" + <> help + "GPG verification (default: none)" + )) + <*> com + where + parseUri s' = + first show $ 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/HLS/stack" + <> footerDoc (Just $ text installToolFooter) + ) + ) + <> command + "set" + (info + (Set <$> setParser <**> helper) + ( progDesc "Set currently active GHC/cabal version" + <> footerDoc (Just $ text setFooter) + ) + ) + <> command + "unset" + (info + (UnSet <$> unsetParser <**> helper) + ( progDesc "Unset currently active GHC/cabal version" + <> footerDoc (Just $ text unsetFooter) + ) + ) + <> command + "rm" + (info + (Rm <$> rmParser <**> helper) + ( progDesc "Remove a GHC/cabal/HLS/stack 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") + ) + <> 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 )) + ) + <> command + "prefetch" + (info + ( (Prefetch + <$> prefetchP + ) <**> helper + ) + (progDesc "Prefetch assets" + <> footerDoc ( Just $ text prefetchFooter )) + ) + <> command + "gc" + (info + ( (GC + <$> gcP + ) <**> helper + ) + (progDesc "Garbage collection" + <> footerDoc ( Just $ text gcFooter )) + ) + <> 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) + ) + ) + <> command + "config" + ( Config + <$> info (configP <**> helper) + (progDesc "Show or set config" <> footerDoc (Just $ text configFooter)) + ) + <> commandGroup "Other commands:" + <> hidden + ) + <|> subparser + ( command + "install-cabal" + (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:" + <> hidden + ) diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs new file mode 100644 index 0000000..cc0470b --- /dev/null +++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.ChangeLog where + + +import GHCup.Types +import GHCup.Utils.Logger +import GHCup.OptParse.Common +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import GHCup.Types.Optics +import GHCup.Utils +import Data.Versions +import URI.ByteString (serializeURIRef') +import GHCup.Utils.Prelude +import GHCup.Utils.File (exec) +import Data.Char (toLower) + + + + --------------- + --[ Options ]-- + --------------- + + +data ChangeLogOptions = ChangeLogOptions + { clOpen :: Bool + , clTool :: Maybe Tool + , clToolVer :: Maybe ToolVersion + } + + + + + --------------- + --[ Parsers ]-- + --------------- + + +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 + "stack" -> Right Stack + e -> Left e + ) + ) + (short 't' <> long "tool" <> metavar "" <> help + "Open changelog for given tool (default: ghc)" + ) + ) + <*> optional (toolVersionArgument Nothing Nothing) + + + + -------------- + --[ Footer ]-- + -------------- + + +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.|] + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +changelog :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => ChangeLogOptions + -> (forall a . ReaderT AppState m a -> m a) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +changelog ChangeLogOptions{..} runAppState runLogger = do + GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo + 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 $ + "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver' + ) + pure ExitSuccess + Just uri -> do + pfreq <- runAppState getPlatformReq + let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri + cmd = case _rPlatform pfreq of + Darwin -> "open" + Linux _ -> "xdg-open" + FreeBSD -> "xdg-open" + Windows -> "start" + + if clOpen + then do + runAppState $ + exec cmd + [T.unpack $ decUTF8Safe $ serializeURIRef' uri] + Nothing + Nothing + >>= \case + Right _ -> pure ExitSuccess + Left e -> logError (T.pack $ prettyShow e) + >> pure (ExitFailure 13) + else liftIO $ putStrLn uri' >> pure ExitSuccess diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs new file mode 100644 index 0000000..64dcdd9 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module GHCup.OptParse.Common where + + +import GHCup +import GHCup.Download +import GHCup.Errors +import GHCup.Platform +import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Utils.Logger +import GHCup.Utils.MegaParsec +import GHCup.Utils.Prelude + +import Control.Exception.Safe +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Bifunctor +import Data.Char +import Data.Either +import Data.Functor +import Data.List ( nub, sort, sortBy ) +import Data.Maybe +import Data.Text ( Text ) +import Data.Versions hiding ( str ) +import Data.Void +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import Safe +import System.FilePath +import URI.ByteString + +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Text.Megaparsec as MP +import GHCup.Version + + + ------------- + --[ Types ]-- + ------------- + +data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal + | ToolTag Tag + +-- a superset of ToolVersion +data SetToolVersion = SetToolVersion GHCTargetVersion + | SetToolTag Tag + | SetRecommended + | SetNext + +prettyToolVer :: ToolVersion -> String +prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v' +prettyToolVer (ToolTag t) = show t + +toSetToolVer :: Maybe ToolVersion -> SetToolVersion +toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' +toSetToolVer (Just (ToolTag t')) = SetToolTag t' +toSetToolVer Nothing = SetRecommended + + + + + -------------- + --[ Parser ]-- + -------------- + + +-- | same as toolVersionParser, except as an argument. +toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion +toolVersionArgument criteria tool = + argument (eitherReader toolVersionEither) + (metavar (mv tool) + <> completer (tagCompleter (fromMaybe GHC tool) []) + <> foldMap (completer . versionCompleter criteria) tool) + where + mv (Just GHC) = "GHC_VERSION|TAG" + mv (Just HLS) = "HLS_VERSION|TAG" + mv _ = "VERSION|TAG" + + +versionParser :: Parser GHCTargetVersion +versionParser = option + (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) + +versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion +versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) + + +-- 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 + + + + --------------------- + --[ Either Parser ]-- + --------------------- + + +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' + [ (`PlatformRequest` FreeBSD) + <$> (archP <* MP.chunk "-") + <*> ( MP.chunk "portbld" + *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) + <|> pure Nothing + ) + <* MP.chunk "-freebsd" + ) + , (`PlatformRequest` Darwin) + <$> (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 + ] + + +bindistParser :: String -> Either String URI +bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString + + +absolutePathParser :: FilePath -> Either String FilePath +absolutePathParser f = case isValid f && isAbsolute f of + True -> Right $ normalise f + False -> Left "Please enter a valid absolute filepath." + +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." + +toolVersionEither :: String -> Either String ToolVersion +toolVersionEither s' = + second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s') + +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 $ "Invalid PVP version for base " <> ver' + other -> Left $ "Unknown tag " <> other + + +tVersionEither :: String -> Either String GHCTargetVersion +tVersionEither = + first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack + + +toolParser :: String -> Either String Tool +toolParser s' | t == T.pack "ghc" = Right GHC + | t == T.pack "cabal" = Right Cabal + | t == T.pack "hls" = Right HLS + | t == T.pack "stack" = Right Stack + | 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 + | t == T.pack "available" = Right ListAvailable + | otherwise = Left ("Unknown criteria: " <> s') + where t = T.toLower (T.pack s') + + +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") + + + + +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') + +gpgParser :: String -> Either String GPGSetting +gpgParser s' | t == T.pack "strict" = Right GPGStrict + | t == T.pack "lax" = Right GPGLax + | t == T.pack "none" = Right GPGNone + | otherwise = Left ("Unknown gpg setting value: " <> s') + where t = T.toLower (T.pack s') + + + + ------------------ + --[ Completers ]-- + ------------------ + +tagCompleter :: Tool -> [String] -> Completer +tagCompleter tool add = listIOCompleter $ do + dirs' <- liftIO getAllDirs + let loggerConfig = LoggerConfig + { lcPrintDebug = False + , consoleOutter = mempty + , fileOutter = mempty + , fancyColors = False + } + let appState = LeanAppState + (Settings True False Never Curl False GHCupURL True GPGNone False) + dirs' + defaultKeyBindings + loggerConfig + + mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF + case mGhcUpInfo of + VRight ghcupInfo -> do + let allTags = filter (/= Old) + $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool) + pure $ nub $ (add ++) $ fmap tagToString allTags + VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add) + + +versionCompleter :: Maybe ListCriteria -> Tool -> Completer +versionCompleter criteria tool = listIOCompleter $ do + dirs' <- liftIO getAllDirs + let loggerConfig = LoggerConfig + { lcPrintDebug = False + , consoleOutter = mempty + , fileOutter = mempty + , fancyColors = False + } + let settings = Settings True False Never Curl False GHCupURL True GPGNone False + let leanAppState = LeanAppState + settings + dirs' + defaultKeyBindings + loggerConfig + mpFreq <- flip runReaderT leanAppState . runE $ platformRequest + mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF + forFold mpFreq $ \pfreq -> do + forFold mGhcUpInfo $ \ghcupInfo -> do + let appState = AppState + settings + dirs' + defaultKeyBindings + ghcupInfo + pfreq + loggerConfig + + runEnv = flip runReaderT appState + + installedVersions <- runEnv $ listVersions (Just tool) criteria + return $ T.unpack . prettyVer . lVer <$> installedVersions + + + + + ----------------- + --[ Utilities ]-- + ----------------- + + +fromVersion :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Maybe ToolVersion + -> Tool + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) +fromVersion tv = fromVersion' (toSetToolVer tv) + +fromVersion' :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => SetToolVersion + -> Tool + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) +fromVersion' SetRecommended tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap mkTVer Just <$> getRecommended dls tool + ?? TagNotFound Recommended tool +fromVersion' (SetToolVersion v) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo (_tvVersion v) tool dls + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) + Right pvpIn -> + lift (getLatestToolFor tool pvpIn dls) >>= \case + Just (pvp_, vi') -> do + v' <- lift $ pvpToVersion pvp_ + when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion (_tvTarget v) v', Just vi') + Nothing -> pure (v, vi) +fromVersion' (SetToolTag Latest) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool +fromVersion' (SetToolTag Recommended) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool +fromVersion' (SetToolTag (Base pvp'')) GHC = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC +fromVersion' SetNext tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + 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 {..} -> isNothing _tvTarget) + $ 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 + Stack -> do + set <- stackSet !? NoToolVersionSet tool + stacks <- rights <$> lift getInstalledStacks + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ stacks) ?? NoToolVersionSet tool + GHCup -> fail "GHCup cannot be set" + let vi = getVersionInfo (_tvVersion next) tool dls + pure (next, vi) +fromVersion' (SetToolTag t') tool = + throwE $ TagNotFound t' tool + + +checkForUpdates :: ( MonadReader env m + , HasGHCupInfo env + , HasDirs env + , HasPlatformReq env + , MonadCatch m + , HasLog env + , MonadThrow m + , MonadIO m + , MonadFail m + ) + => m () +checkForUpdates = do + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo + lInstalled <- listVersions Nothing (Just ListInstalled) + let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled + + forM_ (getLatest dls GHCup) $ \(l, _) -> do + (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer + when (l > ghc_ver) + $ logWarn $ + "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'" + + forM_ (getLatest dls GHC) $ \(l, _) -> do + let mghc_ver = latestInstalled GHC + forM mghc_ver $ \ghc_ver -> + when (l > ghc_ver) + $ logWarn $ + "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) + $ logWarn $ + "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) + $ logWarn $ + "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'" + + forM_ (getLatest dls Stack) $ \(l, _) -> do + let mstack_ver = latestInstalled Stack + forM mstack_ver $ \stack_ver -> + when (l > stack_ver) + $ logWarn $ + "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'" diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs new file mode 100644 index 0000000..fa89c1b --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Compile where + + +import GHCup +import GHCup.Errors +import GHCup.Utils.File +import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Utils.Logger +import GHCup.OptParse.Common +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Codec.Archive ( ArchiveResult ) +import Control.Concurrent (threadDelay) +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Bifunctor +import Data.Functor +import Data.Maybe +import Data.Versions ( Version, prettyVer, version ) +import Data.Text ( Text ) +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Options.Applicative.Help.Pretty ( text ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import System.FilePath (isPathSeparator) +import Text.Read (readEither) + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data CompileCommand = CompileGHC GHCCompileOptions + | CompileHLS HLSCompileOptions + + + + --------------- + --[ Options ]-- + --------------- + + +data GHCCompileOptions = GHCCompileOptions + { targetGhc :: Either Version GitBranch + , bootstrapGhc :: Either Version FilePath + , jobs :: Maybe Int + , buildConfig :: Maybe FilePath + , patchDir :: Maybe FilePath + , crossTarget :: Maybe Text + , addConfArgs :: [Text] + , setCompile :: Bool + , ovewrwiteVer :: Maybe Version + , buildFlavour :: Maybe String + , hadrian :: Bool + , isolateDir :: Maybe FilePath + } + +data HLSCompileOptions = HLSCompileOptions + { targetHLS :: Either Version GitBranch + , jobs :: Maybe Int + , setCompile :: Bool + , ovewrwiteVer :: Maybe Version + , isolateDir :: Maybe FilePath + , cabalProject :: Maybe FilePath + , cabalProjectLocal :: Maybe FilePath + , patchDir :: Maybe FilePath + , targetGHCs :: [ToolVersion] + } + + + + + --------------- + --[ Parsers ]-- + --------------- + + +compileP :: Parser CompileCommand +compileP = subparser + ( command + "ghc" + ( CompileGHC + <$> info + (ghcCompileOpts <**> helper) + ( progDesc "Compile GHC from source" + <> footerDoc (Just $ text compileFooter) + ) + ) + <> command + "hls" + ( CompileHLS + <$> info + (hlsCompileOpts <**> helper) + ( progDesc "Compile HLS from source" + <> footerDoc (Just $ text compileHLSFooter) + ) + ) + ) + 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: + # compile from known version + ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 + # compile from git commit/reference + ghcup compile ghc -j 4 -g master -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|] + + compileHLSFooter = [s|Discussion: + Compiles and installs the specified HLS version. + The last argument is a list of GHC versions to compile for. + These need to be available in PATH prior to compilation. + +Examples: + ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|] + + +ghcCompileOpts :: Parser GHCCompileOptions +ghcCompileOpts = + GHCCompileOptions + <$> ((Left <$> option + (eitherReader + (first (const "Not a valid version") . version . T.pack) + ) + (short 'v' <> long "version" <> metavar "VERSION" <> help + "The tool version to compile" + ) + ) <|> + (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)")) + ))) + <*> option + (eitherReader + (\x -> + (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") + ) + ) + ( 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 + str + (short 'c' <> long "config" <> metavar "CONFIG" <> help + "Absolute path to build config file" + ) + ) + <*> optional + (option + str + (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help + "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" + ) + ) + <*> 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" + ) + <*> 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" + ) + ) + +hlsCompileOpts :: Parser HLSCompileOptions +hlsCompileOpts = + HLSCompileOptions + <$> ((Left <$> option + (eitherReader + (first (const "Not a valid version") . version . T.pack) + ) + (short 'v' <> long "version" <> metavar "VERSION" <> help + "The tool version to compile" + ) + ) <|> + (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)")) + ))) + <*> optional + (option + (eitherReader (readEither @Int)) + (short 'j' <> long "jobs" <> metavar "JOBS" <> help + "How many jobs to use for make" + ) + ) + <*> flag + False + True + (long "set" <> help + "Set as active version after install" + ) + <*> 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 + (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" + ) + ) + <*> optional + (option + str + (long "cabal-project" <> metavar "CABAL_PROJECT" <> help + "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over." + ) + ) + <*> optional + (option + (eitherReader absolutePathParser) + (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help + "Absolute path to a cabal.project.local to be used for the build. Will be copied over." + ) + ) + <*> optional + (option + (eitherReader absolutePathParser) + (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help + "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" + ) + ) + <*> some (toolVersionArgument Nothing (Just GHC)) + + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type GHCEffects = '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , NotInstalled + , DirNotEmpty + , ArchiveResult + , FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , ProcessError + , CopyError + , BuildFailed + ] +type HLSEffects = '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + , NotInstalled + , DirNotEmpty + , ArchiveResult + ] + + + +runCompileGHC :: (MonadUnliftIO m, MonadIO m) + => (ReaderT AppState m (VEither GHCEffects a) -> m (VEither GHCEffects a)) + -> Excepts GHCEffects (ResourceT (ReaderT AppState m)) a + -> m (VEither GHCEffects a) +runCompileGHC runAppState = + runAppState + . runResourceT + . runE + @GHCEffects + +runCompileHLS :: (MonadUnliftIO m, MonadIO m) + => (ReaderT AppState m (VEither HLSEffects a) -> m (VEither HLSEffects a)) + -> Excepts HLSEffects (ResourceT (ReaderT AppState m)) a + -> m (VEither HLSEffects a) +runCompileHLS runAppState = + runAppState + . runResourceT + . runE + @HLSEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +compile :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => CompileCommand + -> Settings + -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +compile compileCommand settings runAppState runLogger = do + VRight Dirs{ .. } <- runAppState (VRight <$> getDirs) + case compileCommand of + (CompileHLS HLSCompileOptions { .. }) -> do + runCompileHLS runAppState (do + case targetHLS of + Left targetVer -> do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo targetVer HLS dls + forM_ (_viPreCompile =<< vi) $ \msg -> do + lift $ logInfo msg + lift $ logInfo + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene + Right _ -> pure () + ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) + targetVer <- liftE $ compileHLS + targetHLS + ghcs + jobs + ovewrwiteVer + isolateDir + cabalProject + cabalProjectLocal + patchDir + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo targetVer HLS dls + when setCompile $ void $ liftE $ + setHLS targetVer + pure (vi, targetVer) + ) + >>= \case + VRight (vi, tv) -> do + runLogger $ logInfo + "HLS successfully compiled and installed" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + liftIO $ putStr (T.unpack $ prettyVer tv) + pure ExitSuccess + VLeft err@(V (BuildFailed tmpdir _)) -> do + case keepDirs settings of + Never -> runLogger $ logError $ T.pack $ prettyShow err + _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> + "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 9 + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 9 + (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do + runLogger $ logError "Hadrian cross compile support is not yet implemented!" + pure $ ExitFailure 9 + (CompileGHC GHCCompileOptions {..}) -> + runCompileGHC runAppState (do + case targetGhc of + Left targetVer -> do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo targetVer GHC dls + forM_ (_viPreCompile =<< vi) $ \msg -> do + lift $ logInfo msg + lift $ logInfo + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene + Right _ -> pure () + targetVer <- liftE $ compileGHC + (first (GHCTargetVersion crossTarget) targetGhc) + ovewrwiteVer + bootstrapGhc + jobs + buildConfig + patchDir + addConfArgs + buildFlavour + hadrian + isolateDir + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo (_tvVersion targetVer) GHC dls + when setCompile $ void $ liftE $ + setGHC targetVer SetGHCOnly + pure (vi, targetVer) + ) + >>= \case + VRight (vi, tv) -> do + runLogger $ logInfo + "GHC successfully compiled and installed" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + liftIO $ putStr (T.unpack $ tVerToText tv) + pure ExitSuccess + VLeft (V (AlreadyInstalled _ v)) -> do + runLogger $ logWarn $ + "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'" + pure ExitSuccess + VLeft (V (DirNotEmpty fp)) -> do + runLogger $ logWarn $ + "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless." + pure $ ExitFailure 3 + VLeft err@(V (BuildFailed tmpdir _)) -> do + case keepDirs settings of + Never -> runLogger $ logError $ T.pack $ prettyShow err + _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> + "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 9 + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 9 diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs new file mode 100644 index 0000000..5e095f6 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Config where + + +import GHCup.Errors +import GHCup.Types +import GHCup.Utils +import GHCup.Utils.Prelude +import GHCup.Utils.Logger +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Bifunctor +import Data.Functor +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit + +import qualified Data.Text as T +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.YAML.Aeson as Y +import Control.Exception.Safe (MonadMask) + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data ConfigCommand + = ShowConfig + | SetConfig String String + | InitConfig + + + + --------------- + --[ Parsers ]-- + --------------- + + +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") + + + + + -------------- + --[ Footer ]-- + -------------- + + +configFooter :: String +configFooter = [s|Examples: + + # show current config + ghcup config + + # initialize config + ghcup config init + + # set configuration pair + ghcup config |] + + + + ----------------- + --[ Utilities ]-- + ----------------- + + +formatConfig :: UserSettings -> String +formatConfig = UTF8.toString . Y.encode1Strict + + +updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings +updateSettings config' settings = do + settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config' + pure $ mergeConf settings' settings + 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 + gpgSetting' = fromMaybe gpgSetting uGPGSetting + in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +config :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => ConfigCommand + -> Settings + -> KeyBindings + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +config configCommand settings keybindings runLogger = case configCommand of + InitConfig -> do + path <- getConfigFilePath + liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings) + runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path + pure ExitSuccess + + ShowConfig -> do + liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings) + pure ExitSuccess + + (SetConfig k v) -> do + case v of + "" -> do + runLogger $ logError "Empty values are not allowed" + pure $ ExitFailure 55 + _ -> do + r <- runE @'[JSONError] $ do + settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings + path <- liftIO getConfigFilePath + liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings) + lift $ runLogger $ logDebug $ T.pack $ show settings' + pure () + + case r of + VRight _ -> pure ExitSuccess + VLeft (V (JSONDecodeError e)) -> do + runLogger $ logError $ "Error decoding config: " <> T.pack e + pure $ ExitFailure 65 + VLeft _ -> pure $ ExitFailure 65 diff --git a/app/ghcup/GHCup/OptParse/DInfo.hs b/app/ghcup/GHCup/OptParse/DInfo.hs new file mode 100644 index 0000000..281f33a --- /dev/null +++ b/app/ghcup/GHCup/OptParse/DInfo.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.DInfo where + + + + +import GHCup +import GHCup.Errors +import GHCup.Version +import GHCup.Types +import GHCup.Utils.Prelude +import GHCup.Utils.Dirs +import GHCup.Utils.Logger + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import GHCup.Utils.File +import Language.Haskell.TH + + + + ----------------- + --[ Utilities ]-- + ----------------- + + +describe_result :: String +describe_result = $( LitE . StringL <$> + runIO (do + CapturedProcess{..} <- do + dirs <- liftIO getAllDirs + let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False) + dirs + defaultKeyBindings + flip runReaderT settings $ executeOut "git" ["describe"] Nothing + case _exitCode of + ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut + ExitFailure _ -> pure numericVer + ) + ) + + +prettyDebugInfo :: DebugInfo -> String +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 + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ] + +runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a)) + -> Excepts DInfoEffects (ReaderT env m) a + -> m (VEither DInfoEffects a) +runDebugInfo runAppState = + runAppState + . runE + @DInfoEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +dinfo :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + , Alternative m + ) + => (ReaderT AppState m (VEither DInfoEffects DebugInfo) + -> m (VEither DInfoEffects DebugInfo)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +dinfo runAppState runLogger = do + runDebugInfo runAppState (liftE getDebugInfo) + >>= \case + VRight di -> do + liftIO $ putStrLn $ prettyDebugInfo di + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 8 diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs new file mode 100644 index 0000000..b3488d1 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.GC where + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) + + + + + + --------------- + --[ Options ]-- + --------------- + + +data GCOptions = GCOptions + { gcOldGHC :: Bool + , gcProfilingLibs :: Bool + , gcShareDir :: Bool + , gcHLSNoGHC :: Bool + , gcCache :: Bool + , gcTmp :: Bool + } + + + + --------------- + --[ Parsers ]-- + --------------- + + +gcP :: Parser GCOptions +gcP = + GCOptions + <$> + switch + (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'") + <*> + switch + (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions") + <*> + switch + (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)") + <*> + switch + (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version") + <*> + switch + (short 'c' <> long "cache" <> help "GC the GHCup cache") + <*> + switch + (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") + + + + -------------- + --[ Footer ]-- + -------------- + + +gcFooter :: String +gcFooter = [s|Discussion: + Performs garbage collection. If no switches are specified, does nothing.|] + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type GCEffects = '[ NotInstalled ] + + +runGC :: MonadUnliftIO m + => (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a)) + -> Excepts GCEffects (ResourceT (ReaderT AppState m)) a + -> m (VEither GCEffects a) +runGC runAppState = + runAppState + . runResourceT + . runE + @GCEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +gc :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => GCOptions + -> (forall a. ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +gc GCOptions{..} runAppState runLogger = runGC runAppState (do + when gcOldGHC rmOldGHC + lift $ when gcProfilingLibs rmProfilingLibs + lift $ when gcShareDir rmShareDir + lift $ when gcHLSNoGHC rmHLSNoGHC + lift $ when gcCache rmCache + lift $ when gcTmp rmTmp + ) >>= \case + VRight _ -> do + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 27 diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs new file mode 100644 index 0000000..386f90d --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module GHCup.OptParse.Install where + + + + +import GHCup.OptParse.Common + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.File +import GHCup.Utils.Logger +import GHCup.Utils.String.QQ + +import Codec.Archive +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Either +import Data.Functor +import Data.Maybe +import Data.Versions hiding ( str ) +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Options.Applicative.Help.Pretty ( text ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString + +import qualified Data.Text as T + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data InstallCommand = InstallGHC InstallOptions + | InstallCabal InstallOptions + | InstallHLS InstallOptions + | InstallStack InstallOptions + + + + + --------------- + --[ Options ]-- + --------------- + + +data InstallOptions = InstallOptions + { instVer :: Maybe ToolVersion + , instPlatform :: Maybe PlatformRequest + , instBindist :: Maybe URI + , instSet :: Bool + , isolateDir :: Maybe FilePath + , forceInstall :: Bool + } + + + + --------------- + --[ Footers ]-- + --------------- + +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.|] + + + + --------------- + --[ Parsers ]-- + --------------- + +installParser :: Parser (Either InstallCommand InstallOptions) +installParser = + (Left <$> subparser + ( command + "ghc" + ( InstallGHC + <$> info + (installOpts (Just GHC) <**> helper) + ( progDesc "Install GHC" + <> footerDoc (Just $ text installGHCFooter) + ) + ) + <> command + "cabal" + ( InstallCabal + <$> info + (installOpts (Just Cabal) <**> helper) + ( progDesc "Install Cabal" + <> footerDoc (Just $ text installCabalFooter) + ) + ) + <> command + "hls" + ( InstallHLS + <$> info + (installOpts (Just HLS) <**> helper) + ( progDesc "Install haskell-language-server" + <> footerDoc (Just $ text installHLSFooter) + ) + ) + <> 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: + # install recommended HLS + ghcup install hls|] + + installStackFooter :: String + installStackFooter = [s|Discussion: + Installs stack binaries into "~/.ghcup/bin" + +Examples: + # install recommended Stack + ghcup install stack|] + + 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/-". + +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|] + + +installOpts :: Maybe Tool -> Parser InstallOptions +installOpts tool = + (\p (u, v) b is f -> InstallOptions v p u b is f) + <$> 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 + (option + (eitherReader bindistParser) + (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help + "Install the specified version from this bindist" + ) + ) + <*> (Just <$> toolVersionArgument Nothing tool) + ) + <|> 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") + + + + + -------------- + --[ Footer ]-- + -------------- + + +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/cabal/hls/stack).|] + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + +type InstallEffects = '[ AlreadyInstalled + , UnknownArchive + , ArchiveResult + , FileDoesNotExistError + , CopyError + , NotInstalled + , DirNotEmpty + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , GPGError + , DownloadFailed + , TarDirDoesNotExist + , NextVerNotFound + , NoToolVersionSet + , FileAlreadyExistsError + , ProcessError + ] + + +runInstTool :: AppState + -> Maybe PlatformRequest + -> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a + -> IO (VEither InstallEffects a) +runInstTool appstate' mInstPlatform = + flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) + . runResourceT + . runE + @InstallEffects + + + + ------------------- + --[ Entrypoints ]-- + ------------------- + + +install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode +install installCommand settings getAppState' runLogger = case installCommand of + (Right iopts) -> do + runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.") + installGHC iopts + (Left (InstallGHC iopts)) -> installGHC iopts + (Left (InstallCabal iopts)) -> installCabal iopts + (Left (InstallHLS iopts)) -> installHLS iopts + (Left (InstallStack iopts)) -> installStack iopts + where + installGHC :: InstallOptions -> IO ExitCode + installGHC InstallOptions{..} = do + s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' + (case instBindist of + Nothing -> runInstTool s' instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBin + (_tvVersion v) + isolateDir + forceInstall + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi + Just uri -> do + runInstTool s'{ settings = settings {noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") + (_tvVersion v) + isolateDir + forceInstall + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi + ) + >>= \case + VRight vi -> do + runLogger $ logInfo "GHC installation successful" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft (V (AlreadyInstalled _ v)) -> do + runLogger $ logWarn $ + "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'" + pure ExitSuccess + VLeft (V (DirNotEmpty fp)) -> do + runLogger $ logWarn $ + "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless." + pure $ ExitFailure 3 + VLeft err@(V (BuildFailed tmpdir _)) -> do + case keepDirs settings of + Never -> runLogger (logError $ T.pack $ prettyShow err) + _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> + "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 + logError $ T.pack $ prettyShow e + logError $ "Also check the logs in " <> T.pack logsDir + pure $ ExitFailure 3 + + + installCabal :: InstallOptions -> IO ExitCode + installCabal InstallOptions{..} = do + s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' + (case instBindist of + Nothing -> runInstTool s' instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBin + (_tvVersion v) + isolateDir + forceInstall + pure vi + Just uri -> do + runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + forceInstall + pure vi + ) + >>= \case + VRight vi -> do + runLogger $ logInfo "Cabal installation successful" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft (V (AlreadyInstalled _ v)) -> do + runLogger $ logWarn $ + "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'" + pure ExitSuccess + VLeft (V (FileAlreadyExistsError fp)) -> do + runLogger $ logWarn $ + "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." + pure $ ExitFailure 3 + VLeft e -> do + runLogger $ do + logError $ T.pack $ prettyShow e + logError $ "Also check the logs in " <> T.pack logsDir + pure $ ExitFailure 4 + + installHLS :: InstallOptions -> IO ExitCode + installHLS InstallOptions{..} = do + s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' + (case instBindist of + Nothing -> runInstTool s' instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBin + (_tvVersion v) + isolateDir + forceInstall + pure vi + Just uri -> do + runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + forceInstall + pure vi + ) + >>= \case + VRight vi -> do + runLogger $ logInfo "HLS installation successful" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft (V (AlreadyInstalled _ v)) -> do + runLogger $ logWarn $ + "HLS ver " + <> prettyVer v + <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force " + <> prettyVer v + <> "'" + pure ExitSuccess + VLeft (V (FileAlreadyExistsError fp)) -> do + runLogger $ logWarn $ + "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." + pure $ ExitFailure 3 + VLeft e -> do + runLogger $ do + logError $ T.pack $ prettyShow e + logError $ "Also check the logs in " <> T.pack logsDir + pure $ ExitFailure 4 + + installStack :: InstallOptions -> IO ExitCode + installStack InstallOptions{..} = do + s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' + (case instBindist of + Nothing -> runInstTool s' instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBin + (_tvVersion v) + isolateDir + forceInstall + pure vi + Just uri -> do + runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + forceInstall + pure vi + ) + >>= \case + VRight vi -> do + runLogger $ logInfo "Stack installation successful" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft (V (AlreadyInstalled _ v)) -> do + runLogger $ logWarn $ + "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'" + pure ExitSuccess + VLeft (V (FileAlreadyExistsError fp)) -> do + runLogger $ logWarn $ + "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." + pure $ ExitFailure 3 + VLeft e -> do + runLogger $ do + logError $ T.pack $ prettyShow e + logError $ "Also check the logs in " <> T.pack logsDir + pure $ ExitFailure 4 + diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs new file mode 100644 index 0000000..64c1c40 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.List where + + + + +import GHCup +import GHCup.Types +import GHCup.OptParse.Common + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Char +import Data.List ( intercalate, sort ) +import Data.Functor +import Data.Maybe +import Data.Versions hiding ( str ) +import Data.Void +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import System.Console.Pretty hiding ( color ) + +import qualified Data.Text as T +import qualified System.Console.Pretty as Pretty +import Control.Exception.Safe (MonadMask) +import qualified Text.Megaparsec as MP +import qualified Text.Megaparsec.Char as MPC + + + + + + + --------------- + --[ Options ]-- + --------------- + + +data ListOptions = ListOptions + { loTool :: Maybe Tool + , lCriteria :: Maybe ListCriteria + , lRawFormat :: Bool + } + + + + + --------------- + --[ Parsers ]-- + --------------- + + +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/set/available tool versions" + ) + ) + <*> switch + (short 'r' <> long "raw-format" <> help "More machine-parsable format" + ) + + + + + ----------------- + --[ Utilities ]-- + ----------------- + + +printListResult :: Bool -> Bool -> [ListResult] -> IO () +printListResult no_color raw lr = do + + let + color | raw || no_color = (\_ x -> x) + | 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 = "" + + let + rows = + (\x -> if raw + then x + else [color Green "", "Tool", "Version", "Tags", "Notes"] : x + ) + . fmap + (\ListResult {..} -> + let marks = if +#if defined(IS_WINDOWS) + | lSet -> (color Green "IS") + | lInstalled -> (color Green "I ") + | otherwise -> (color Red "X ") +#else + | lSet -> (color Green "✔✔") + | lInstalled -> (color Green "✓ ") + | otherwise -> (color Red "✗ ") +#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 + ) + ] + ) + $ lr + let cols = + foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows + lengths = fmap (maximum . fmap strWidth) cols + padded = fmap (\xs -> zipWith padTo xs lengths) rows + + forM_ padded $ \row -> putStrLn $ unwords row + where + + 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 + + + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +list :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => ListOptions + -> Bool + -> (ReaderT AppState m ExitCode -> m ExitCode) + -> m ExitCode +list ListOptions{..} no_color runAppState = + runAppState (do + l <- listVersions loTool lCriteria + liftIO $ printListResult no_color lRawFormat l + pure ExitSuccess + ) diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs new file mode 100644 index 0000000..75537de --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Nuke where + + + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import Control.DeepSeq +import Control.Exception +import Control.Concurrent (threadDelay) + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type NukeEffects = '[ NotInstalled ] + + +runNuke :: AppState + -> Excepts NukeEffects (ReaderT AppState m) a + -> m (VEither NukeEffects a) +runNuke s' = + flip runReaderT s' . runE @NukeEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +nuke :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => IO AppState + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +nuke appState runLogger = do + s' <- liftIO appState + void $ liftIO $ evaluate $ force s' + runNuke s' (do + 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 + + lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀" + lift $ logInfo "Nuking in 3...2...1" + + lInstalled <- lift $ listVersions Nothing (Just ListInstalled) + + forM_ lInstalled (liftE . rmTool) + + lift rmGhcupDirs + + ) >>= \case + VRight leftOverFiles + | null leftOverFiles -> do + runLogger $ logInfo "Nuclear Annihilation complete!" + pure ExitSuccess + | otherwise -> do + runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually." + liftIO $ forM_ leftOverFiles putStrLn + pure ExitSuccess + + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 15 diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs new file mode 100644 index 0000000..99fefa4 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Prefetch where + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger +import GHCup.OptParse.Common +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import GHCup.Utils.Prelude +import GHCup.Download (getDownloadsF) + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion) + | PrefetchCabal PrefetchOptions (Maybe ToolVersion) + | PrefetchHLS PrefetchOptions (Maybe ToolVersion) + | PrefetchStack PrefetchOptions (Maybe ToolVersion) + | PrefetchMetadata + + + + + + --------------- + --[ Options ]-- + --------------- + + +data PrefetchOptions = PrefetchOptions { + pfCacheDir :: Maybe FilePath +} + +data PrefetchGHCOptions = PrefetchGHCOptions { + pfGHCSrc :: Bool + , pfGHCCacheDir :: Maybe FilePath +} + + + + --------------- + --[ Parsers ]-- + --------------- + + +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" + (PrefetchMetadata <$ info + helper + ( progDesc "Download ghcup's metadata, needed for various operations") + ) + ) + + + + -------------- + --[ Footer ]-- + -------------- + + +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|] + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type PrefetchEffects = '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + , NoDownload + , DigestError + , GPGError + , DownloadFailed + , JSONError + , FileDoesNotExistError ] + + +runPrefetch :: MonadUnliftIO m + => (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a)) + -> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a + -> m (VEither PrefetchEffects a) +runPrefetch runAppState = + runAppState + . runResourceT + . runE + @PrefetchEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +prefetch :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => PrefetchCommand + -> (forall a. ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +prefetch prefetchCommand runAppState runLogger = + runPrefetch runAppState (do + case prefetchCommand 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 + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 15 diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs new file mode 100644 index 0000000..591840e --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Rm where + + + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Utils.Logger +import GHCup.OptParse.Common +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Data.Versions hiding ( str ) +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data RmCommand = RmGHC RmOptions + | RmCabal Version + | RmHLS Version + | RmStack Version + + + + + --------------- + --[ Options ]-- + --------------- + + +data RmOptions = RmOptions + { ghcVer :: GHCTargetVersion + } + + + + + --------------- + --[ Parsers ]-- + --------------- + + +rmParser :: Parser (Either RmCommand RmOptions) +rmParser = + (Left <$> subparser + ( command + "ghc" + (RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version")) + <> command + "cabal" + ( RmCabal + <$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper) + (progDesc "Remove Cabal version") + ) + <> command + "hls" + ( RmHLS + <$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper) + (progDesc "Remove haskell-language-server version") + ) + <> 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 + + + + + -------------- + --[ Footer ]-- + -------------- + + +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/cabal/hls/stack).|] + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type RmEffects = '[ NotInstalled ] + + +runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a)) + -> Excepts RmEffects (ReaderT env m) a + -> m (VEither RmEffects a) +runRm runAppState = + runAppState + . runE + @RmEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +rm :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => Either RmCommand RmOptions + -> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo)) + -> m (VEither RmEffects (Maybe VersionInfo))) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +rm rmCommand runAppState runLogger = case rmCommand of + (Right rmopts) -> do + runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.") + rmGHC' rmopts + (Left (RmGHC rmopts)) -> rmGHC' rmopts + (Left (RmCabal rmopts)) -> rmCabal' rmopts + (Left (RmHLS rmopts)) -> rmHLS' rmopts + (Left (RmStack rmopts)) -> rmStack' rmopts + + where + rmGHC' RmOptions{..} = + runRm runAppState (do + liftE $ + rmGHCVer ghcVer + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + pure (getVersionInfo (_tvVersion ghcVer) GHC dls) + ) + >>= \case + VRight vi -> do + forM_ (_viPostRemove =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 7 + + rmCabal' tv = + runRm runAppState (do + liftE $ + rmCabalVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + pure (getVersionInfo tv Cabal dls) + ) + >>= \case + VRight vi -> do + forM_ (_viPostRemove =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 15 + + rmHLS' tv = + runRm runAppState (do + liftE $ + rmHLSVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + pure (getVersionInfo tv HLS dls) + ) + >>= \case + VRight vi -> do + forM_ (_viPostRemove =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 15 + + rmStack' tv = + runRm runAppState (do + liftE $ + rmStackVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + pure (getVersionInfo tv Stack dls) + ) + >>= \case + VRight vi -> do + forM_ (_viPostRemove =<< vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 15 + diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs new file mode 100644 index 0000000..b03d53a --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Set where + + + + +import GHCup.OptParse.Common + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Either +import Data.Functor +import Data.Maybe +import Data.Versions hiding ( str ) +import GHC.Unicode +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Options.Applicative.Help.Pretty ( text ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Data.Bifunctor (second) +import Control.Exception.Safe (MonadMask) +import GHCup.Types.Optics + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data SetCommand = SetGHC SetOptions + | SetCabal SetOptions + | SetHLS SetOptions + | SetStack SetOptions + + + + + --------------- + --[ Options ]-- + --------------- + + +data SetOptions = SetOptions + { sToolVer :: SetToolVersion + } + + + + + --------------- + --[ Parsers ]-- + --------------- + + +setParser :: Parser (Either SetCommand SetOptions) +setParser = + (Left <$> subparser + ( command + "ghc" + ( SetGHC + <$> info + (setOpts (Just GHC) <**> helper) + ( progDesc "Set GHC version" + <> footerDoc (Just $ text setGHCFooter) + ) + ) + <> command + "cabal" + ( SetCabal + <$> info + (setOpts (Just Cabal) <**> helper) + ( progDesc "Set Cabal version" + <> footerDoc (Just $ text setCabalFooter) + ) + ) + <> command + "hls" + ( SetHLS + <$> info + (setOpts (Just HLS) <**> helper) + ( progDesc "Set haskell-language-server version" + <> footerDoc (Just $ text setHLSFooter) + ) + ) + <> command + "stack" + ( SetStack + <$> info + (setOpts (Just Stack) <**> helper) + ( progDesc "Set stack version" + <> footerDoc (Just $ text setStackFooter) + ) + ) + ) + ) + <|> (Right <$> setOpts Nothing) + 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.|] + + 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 +setOpts tool = SetOptions <$> + (fromMaybe SetRecommended <$> + optional (setVersionArgument (Just ListInstalled) tool)) + +setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion +setVersionArgument criteria tool = + argument (eitherReader setEither) + (metavar "VERSION|TAG|next" + <> completer (tagCompleter (fromMaybe GHC tool) ["next"]) + <> foldMap (completer . versionCompleter criteria) tool) + where + setEither s' = + parseSet s' + <|> second SetToolTag (tagEither s') + <|> second SetToolVersion (tVersionEither s') + parseSet s' = case fmap toLower s' of + "next" -> Right SetNext + other -> Left $ "Unknown tag/version " <> other + + + + + -------------- + --[ Footer ]-- + -------------- + + +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/cabal/hls/stack).|] + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type SetGHCEffects = '[ FileDoesNotExistError + , NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet] + +runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a)) + -> Excepts SetGHCEffects (ReaderT env m) a + -> m (VEither SetGHCEffects a) +runSetGHC runAppState = + runAppState + . runE + @SetGHCEffects + + +type SetCabalEffects = '[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet] + +runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a)) + -> Excepts SetCabalEffects (ReaderT env m) a + -> m (VEither SetCabalEffects a) +runSetCabal runAppState = + runAppState + . runE + @SetCabalEffects + + +type SetHLSEffects = '[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet] + +runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a)) + -> Excepts SetHLSEffects (ReaderT env m) a + -> m (VEither SetHLSEffects a) +runSetHLS runAppState = + runAppState + . runE + @SetHLSEffects + + +type SetStackEffects = '[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet] + +runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a)) + -> Excepts SetStackEffects (ReaderT env m) a + -> m (VEither SetStackEffects a) +runSetStack runAppState = + runAppState + . runE + @SetStackEffects + + + + ------------------- + --[ Entrypoints ]-- + ------------------- + + +set :: forall m env. + ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + , HasDirs env + , HasLog env + ) + => Either SetCommand SetOptions + -> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion) + -> m (VEither eff GHCTargetVersion)) + -> (forall eff. ReaderT env m (VEither eff GHCTargetVersion) + -> m (VEither eff GHCTargetVersion)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +set setCommand runAppState runLeanAppState runLogger = case setCommand of + (Right sopts) -> do + runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") + setGHC' sopts + (Left (SetGHC sopts)) -> setGHC' sopts + (Left (SetCabal sopts)) -> setCabal' sopts + (Left (SetHLS sopts)) -> setHLS' sopts + (Left (SetStack sopts)) -> setStack' sopts + + where + setGHC' :: SetOptions + -> m ExitCode + setGHC' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v) + _ -> runSetGHC runAppState (do + v <- liftE $ fst <$> fromVersion' sToolVer GHC + liftE $ setGHC v SetGHCOnly + ) + >>= \case + VRight GHCTargetVersion{..} -> do + runLogger + $ logInfo $ + "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 5 + + + setCabal' :: SetOptions + -> m ExitCode + setCabal' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v) + _ -> runSetCabal runAppState (do + v <- liftE $ fst <$> fromVersion' sToolVer Cabal + liftE $ setCabal (_tvVersion v) + pure v + ) + >>= \case + VRight GHCTargetVersion{..} -> do + runLogger + $ logInfo $ + "Cabal " <> prettyVer _tvVersion <> " successfully set as default version" + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 14 + + setHLS' :: SetOptions + -> m ExitCode + setHLS' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v) + _ -> runSetHLS runAppState (do + v <- liftE $ fst <$> fromVersion' sToolVer HLS + liftE $ setHLS (_tvVersion v) + pure v + ) + >>= \case + VRight GHCTargetVersion{..} -> do + runLogger + $ logInfo $ + "HLS " <> prettyVer _tvVersion <> " successfully set as default version" + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 14 + + + setStack' :: SetOptions + -> m ExitCode + setStack' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v) + _ -> runSetStack runAppState (do + v <- liftE $ fst <$> fromVersion' sToolVer Stack + liftE $ setStack (_tvVersion v) + pure v + ) + >>= \case + VRight GHCTargetVersion{..} -> do + runLogger + $ logInfo $ + "Stack " <> prettyVer _tvVersion <> " successfully set as default version" + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 14 diff --git a/app/ghcup/GHCup/OptParse/ToolRequirements.hs b/app/ghcup/GHCup/OptParse/ToolRequirements.hs new file mode 100644 index 0000000..2f34d02 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.ToolRequirements where + + +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Control.Exception.Safe (MonadMask) +import GHCup.Types.Optics +import GHCup.Platform +import GHCup.Utils.Prelude +import GHCup.Requirements +import System.IO + + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoToolRequirements ] + + +runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a)) + -> Excepts ToolRequirementsEffects (ReaderT env m) a + -> m (VEither ToolRequirementsEffects a) +runToolRequirements runAppState = + runAppState + . runE + @ToolRequirementsEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +toolRequirements :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + , Alternative m + ) + => (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ())) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +toolRequirements runAppState runLogger = runToolRequirements runAppState (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 + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 12 diff --git a/app/ghcup/GHCup/OptParse/UnSet.hs b/app/ghcup/GHCup/OptParse/UnSet.hs new file mode 100644 index 0000000..fd3c4fa --- /dev/null +++ b/app/ghcup/GHCup/OptParse/UnSet.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.UnSet where + + + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Options.Applicative.Help.Pretty ( text ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import GHCup.Types.Optics + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data UnsetCommand = UnsetGHC UnsetOptions + | UnsetCabal UnsetOptions + | UnsetHLS UnsetOptions + | UnsetStack UnsetOptions + + + + + --------------- + --[ Options ]-- + --------------- + + +data UnsetOptions = UnsetOptions + { sToolVer :: Maybe T.Text -- target platform triple + } + + + + + --------------- + --[ Parsers ]-- + --------------- + + +unsetParser :: Parser UnsetCommand +unsetParser = + subparser + ( command + "ghc" + ( UnsetGHC + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset GHC version" + <> footerDoc (Just $ text unsetGHCFooter) + ) + ) + <> command + "cabal" + ( UnsetCabal + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset Cabal version" + <> footerDoc (Just $ text unsetCabalFooter) + ) + ) + <> command + "hls" + ( UnsetHLS + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset haskell-language-server version" + <> footerDoc (Just $ text unsetHLSFooter) + ) + ) + <> command + "stack" + ( UnsetStack + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset stack version" + <> footerDoc (Just $ text unsetStackFooter) + ) + ) + ) + where + unsetGHCFooter :: String + unsetGHCFooter = [s|Discussion: + Unsets the the current GHC version. That means there won't + be a ~/.ghcup/bin/ghc anymore.|] + + unsetCabalFooter :: String + unsetCabalFooter = [s|Discussion: + Unsets the the current Cabal version.|] + + unsetStackFooter :: String + unsetStackFooter = [s|Discussion: + Unsets the the current Stack version.|] + + unsetHLSFooter :: String + unsetHLSFooter = [s|Discussion: + Unsets the the current haskell-language-server version.|] + + +unsetOpts :: Parser UnsetOptions +unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE")) + + + + -------------- + --[ Footer ]-- + -------------- + + +unsetFooter :: String +unsetFooter = [s|Discussion: + Unsets the currently active GHC or cabal version.|] + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type UnsetEffects = '[ NotInstalled ] + + +runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a)) + -> Excepts UnsetEffects (ReaderT env m) a + -> m (VEither UnsetEffects a) +runUnsetGHC runLeanAppState = + runLeanAppState + . runE + @UnsetEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +unset :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + , HasDirs env + , HasLog env + ) + => UnsetCommand + -> (ReaderT env m (VEither UnsetEffects ()) + -> m (VEither UnsetEffects ())) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +unset unsetCommand runLeanAppState runLogger = case unsetCommand of + (UnsetGHC (UnsetOptions triple)) -> runUnsetGHC runLeanAppState (unsetGHC triple) + >>= \case + VRight _ -> do + runLogger $ logInfo "GHC successfully unset" + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 14 + (UnsetCabal (UnsetOptions _)) -> do + void $ runLeanAppState (VRight <$> unsetCabal) + runLogger $ logInfo "Cabal successfully unset" + pure ExitSuccess + (UnsetHLS (UnsetOptions _)) -> do + void $ runLeanAppState (VRight <$> unsetHLS) + runLogger $ logInfo "HLS successfully unset" + pure ExitSuccess + (UnsetStack (UnsetOptions _)) -> do + void $ runLeanAppState (VRight <$> unsetStack) + runLogger $ logInfo "Stack successfully unset" + pure ExitSuccess diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs new file mode 100644 index 0000000..878b879 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Upgrade where + + + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Utils.Logger + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import System.Environment +import GHCup.Utils +import System.FilePath +import GHCup.Types.Optics +import Data.Versions hiding (str) + + + + + + + --------------- + --[ Options ]-- + --------------- + + +data UpgradeOpts = UpgradeInplace + | UpgradeAt FilePath + | UpgradeGHCupDir + deriving Show + + + + + --------------- + --[ Parsers ]-- + --------------- + + +upgradeOptsP :: Parser UpgradeOpts +upgradeOptsP = + flag' + UpgradeInplace + (short 'i' <> long "inplace" <> help + "Upgrade ghcup in-place (wherever it's at)" + ) + <|> ( UpgradeAt + <$> option + str + (short 't' <> long "target" <> metavar "TARGET_DIR" <> help + "Absolute filepath to write ghcup into" + ) + ) + <|> pure UpgradeGHCupDir + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type UpgradeEffects = '[ DigestError + , GPGError + , NoDownload + , NoUpdate + , FileDoesNotExistError + , CopyError + , DownloadFailed + ] + + +runUpgrade :: MonadUnliftIO m + => (ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) + -> Excepts UpgradeEffects (ResourceT (ReaderT AppState m)) a + -> m (VEither UpgradeEffects a) +runUpgrade runAppState = + runAppState + . runResourceT + . runE + @UpgradeEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +upgrade :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => UpgradeOpts + -> Bool + -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +upgrade uOpts force' runAppState runLogger = do + VRight Dirs{ .. } <- runAppState (VRight <$> getDirs) + target <- case uOpts of + UpgradeInplace -> Just <$> liftIO getExecutablePath + (UpgradeAt p) -> pure $ Just p + UpgradeGHCupDir -> pure (Just (binDir "ghcup" <> exeExt)) + + runUpgrade runAppState (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 + runLogger $ logInfo $ + "Successfully upgraded GHCup to version " <> pretty_v + forM_ (_viPostInstall vi) $ \msg -> + runLogger $ logInfo msg + pure ExitSuccess + VLeft (V NoUpdate) -> do + runLogger $ logWarn "No GHCup update available" + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 11 diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs new file mode 100644 index 0000000..02c27b6 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.Whereis where + + + + +import GHCup +import GHCup.Errors +import GHCup.OptParse.Common +import GHCup.Types +import GHCup.Utils.Logger +import GHCup.Utils.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Data.Maybe +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Options.Applicative.Help.Pretty ( text ) +import Prelude hiding ( appendFile ) +import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import System.FilePath (takeDirectory) +import GHCup.Types.Optics + + + + + ---------------- + --[ Commands ]-- + ---------------- + + +data WhereisCommand = WhereisTool Tool (Maybe ToolVersion) + | WhereisBaseDir + | WhereisBinDir + | WhereisCacheDir + | WhereisLogsDir + | WhereisConfDir + + + + + + --------------- + --[ Options ]-- + --------------- + + +data WhereisOptions = WhereisOptions { + directory :: Bool +} + + + + + --------------- + --[ Parsers ]-- + --------------- + + +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/" 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|] + + + + -------------- + --[ Footer ]-- + -------------- + + +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/" directory. + For cabal/stack/hls this the binary usually at "~/.ghcup/bin/-". + +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|] + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type WhereisEffects = '[ NotInstalled + , NoToolVersionSet + , NextVerNotFound + , TagNotFound + ] + + +runLeanWhereIs :: (MonadUnliftIO m, MonadIO m) + => LeanAppState + -> Excepts WhereisEffects (ReaderT LeanAppState m) a + -> m (VEither WhereisEffects a) +runLeanWhereIs leanAppstate = + -- Don't use runLeanAppState here, which is disabled on windows. + -- This is the only command on all platforms that doesn't need full appstate. + flip runReaderT leanAppstate + . runE + @WhereisEffects + + +runWhereIs :: (MonadUnliftIO m, MonadIO m) + => (ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a)) + -> Excepts WhereisEffects (ReaderT AppState m) a + -> m (VEither WhereisEffects a) +runWhereIs runAppState = + runAppState + . runE + @WhereisEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +whereis :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => WhereisCommand + -> WhereisOptions + -> (forall a. ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a)) + -> LeanAppState + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do + Dirs{ .. } <- runReaderT getDirs leanAppstate + case (whereisCommand, whereisOptions) of + (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) -> + runLeanWhereIs leanAppstate (do + loc <- liftE $ whereIsTool tool v + if directory + then pure $ takeDirectory loc + else pure loc + ) + >>= \case + VRight r -> do + liftIO $ putStr r + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 30 + + (WhereisTool tool whereVer, WhereisOptions{..}) -> do + runWhereIs runAppState (do + (v, _) <- liftE $ fromVersion whereVer tool + loc <- liftE $ whereIsTool tool v + if directory + then pure $ takeDirectory loc + else pure loc + ) + >>= \case + VRight r -> do + liftIO $ putStr r + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 30 + + (WhereisBaseDir, _) -> do + liftIO $ putStr baseDir + pure ExitSuccess + + (WhereisBinDir, _) -> do + liftIO $ putStr binDir + pure ExitSuccess + + (WhereisCacheDir, _) -> do + liftIO $ putStr cacheDir + pure ExitSuccess + + (WhereisLogsDir, _) -> do + liftIO $ putStr logsDir + pure ExitSuccess + + (WhereisConfDir, _) -> do + liftIO $ putStr confDir + pure ExitSuccess diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e1f0bd9..38bed06 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -5,7 +5,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -15,44 +14,31 @@ module Main where import BrickMain ( brickMain ) #endif -import GHCup +import GHCup.OptParse + import GHCup.Download import GHCup.Errors import GHCup.Platform -import GHCup.Requirements import GHCup.Types -import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude import GHCup.Utils.String.QQ import GHCup.Version import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) -import Codec.Archive import Control.Concurrent import Control.Concurrent.Async -import Control.DeepSeq ( force ) -import Control.Exception ( evaluate ) import Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Reader -import Control.Monad.Trans.Resource import Data.Aeson ( decodeStrict', Value ) import Data.Aeson.Encode.Pretty ( encodePretty ) -import Data.Bifunctor -import Data.Char import Data.Either import Data.Functor -import Data.List ( intercalate, nub, sort, sortBy ) import Data.Maybe -import Data.Text ( Text ) -import Data.Versions hiding ( str ) -import Data.Void import GHC.IO.Encoding import Haskus.Utils.Variant.Excepts import Language.Haskell.TH @@ -60,1522 +46,18 @@ import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) import Options.Applicative hiding ( style ) import Options.Applicative.Help.Pretty ( text ) import Prelude hiding ( appendFile ) -import Safe -import System.Console.Pretty hiding ( color ) -import qualified System.Console.Pretty as Pretty import System.Environment import System.Exit -import System.FilePath import System.IO hiding ( appendFile ) -import Text.Read hiding ( lift ) import Text.PrettyPrint.HughesPJClass ( prettyShow ) -import URI.ByteString import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8 -import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as E -import qualified Data.YAML.Aeson as Y -import qualified Text.Megaparsec as MP -import qualified Text.Megaparsec.Char as MPC -data Options = Options - { - -- global options - optVerbose :: Maybe Bool - , optCache :: Maybe Bool - , optUrlSource :: Maybe URI - , optNoVerify :: Maybe Bool - , optKeepDirs :: Maybe KeepDirs - , optsDownloader :: Maybe Downloader - , optNoNetwork :: Maybe Bool - , optGpg :: Maybe GPGSetting - -- commands - , optCommand :: Command - } - -data Command - = Install (Either InstallCommand InstallOptions) - | InstallCabalLegacy InstallOptions - | Set (Either SetCommand SetOptions) - | UnSet UnsetCommand - | List ListOptions - | Rm (Either RmCommand RmOptions) - | DInfo - | Compile CompileCommand - | Config ConfigCommand - | Whereis WhereisOptions WhereisCommand - | Upgrade UpgradeOpts Bool - | ToolRequirements - | ChangeLog ChangeLogOptions - | Nuke -#if defined(BRICK) - | Interactive -#endif - | Prefetch PrefetchCommand - | GC GCOptions - -data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal - | ToolTag Tag - -prettyToolVer :: ToolVersion -> String -prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v' -prettyToolVer (ToolTag t) = show t - -toSetToolVer :: Maybe ToolVersion -> SetToolVersion -toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' -toSetToolVer (Just (ToolTag t')) = SetToolTag t' -toSetToolVer Nothing = SetRecommended - - -data InstallCommand = InstallGHC InstallOptions - | InstallCabal InstallOptions - | InstallHLS InstallOptions - | InstallStack InstallOptions - -data InstallOptions = InstallOptions - { instVer :: Maybe ToolVersion - , instPlatform :: Maybe PlatformRequest - , instBindist :: Maybe URI - , instSet :: Bool - , isolateDir :: Maybe FilePath - , forceInstall :: Bool - } - -data GCOptions = GCOptions - { gcOldGHC :: Bool - , gcProfilingLibs :: Bool - , gcShareDir :: Bool - , gcHLSNoGHC :: Bool - , gcCache :: Bool - , gcTmp :: Bool - } - -data SetCommand = SetGHC SetOptions - | SetCabal SetOptions - | SetHLS SetOptions - | SetStack SetOptions - -data UnsetCommand = UnsetGHC UnsetOptions - | UnsetCabal UnsetOptions - | UnsetHLS UnsetOptions - | UnsetStack UnsetOptions - --- a superset of ToolVersion -data SetToolVersion = SetToolVersion GHCTargetVersion - | SetToolTag Tag - | SetRecommended - | SetNext - -data SetOptions = SetOptions - { sToolVer :: SetToolVersion - } - -data UnsetOptions = UnsetOptions - { sToolVer :: Maybe Text -- target platform triple - } - -data ListOptions = ListOptions - { loTool :: Maybe Tool - , lCriteria :: Maybe ListCriteria - , lRawFormat :: Bool - } - -data RmCommand = RmGHC RmOptions - | RmCabal Version - | RmHLS Version - | RmStack Version - -data RmOptions = RmOptions - { ghcVer :: GHCTargetVersion - } - - -data CompileCommand = CompileGHC GHCCompileOptions - | CompileHLS HLSCompileOptions - -data ConfigCommand = ShowConfig | SetConfig String String | InitConfig - -data GHCCompileOptions = GHCCompileOptions - { targetGhc :: Either Version GitBranch - , bootstrapGhc :: Either Version FilePath - , jobs :: Maybe Int - , buildConfig :: Maybe FilePath - , patchDir :: Maybe FilePath - , crossTarget :: Maybe Text - , addConfArgs :: [Text] - , setCompile :: Bool - , ovewrwiteVer :: Maybe Version - , buildFlavour :: Maybe String - , hadrian :: Bool - , isolateDir :: Maybe FilePath - } - -data HLSCompileOptions = HLSCompileOptions - { targetHLS :: Either Version GitBranch - , jobs :: Maybe Int - , setCompile :: Bool - , ovewrwiteVer :: Maybe Version - , isolateDir :: Maybe FilePath - , cabalProject :: Maybe FilePath - , cabalProjectLocal :: Maybe FilePath - , patchDir :: Maybe FilePath - , targetGHCs :: [ToolVersion] - } - -data UpgradeOpts = UpgradeInplace - | UpgradeAt FilePath - | UpgradeGHCupDir - deriving Show - -data ChangeLogOptions = ChangeLogOptions - { clOpen :: Bool - , clTool :: Maybe Tool - , clToolVer :: Maybe ToolVersion - } - - -data WhereisCommand = WhereisTool Tool (Maybe ToolVersion) - | WhereisBaseDir - | WhereisBinDir - | WhereisCacheDir - | WhereisLogsDir - | WhereisConfDir - -data WhereisOptions = WhereisOptions { - directory :: Bool -} - -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 - - -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)") - <*> (optional - (option - (eitherReader parseUri) - ( short 's' - <> long "url-source" - <> metavar "URL" - <> help "Alternative ghcup download info url" - <> internal - ) - ) - ) - <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)")) - <*> optional (option - (eitherReader keepOnParser) - ( long "keep" - <> metavar "" - <> help - "Keep build directories? (default: errors)" - <> hidden - )) - <*> optional (option - (eitherReader downloaderParser) - ( long "downloader" -#if defined(INTERNAL_DOWNLOADER) - <> metavar "" - <> help - "Downloader to use (default: internal)" -#else - <> metavar "" - <> help - "Downloader to use (default: curl)" -#endif - <> hidden - )) - <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.") - <*> optional (option - (eitherReader gpgParser) - ( long "gpg" - <> metavar "" - <> help - "GPG verification (default: none)" - )) - <*> com - where - parseUri s' = - first show $ 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/HLS/stack" - <> footerDoc (Just $ text installToolFooter) - ) - ) - <> command - "set" - (info - (Set <$> setParser <**> helper) - ( progDesc "Set currently active GHC/cabal version" - <> footerDoc (Just $ text setFooter) - ) - ) - <> command - "unset" - (info - (UnSet <$> unsetParser <**> helper) - ( progDesc "Unset currently active GHC/cabal version" - <> footerDoc (Just $ text unsetFooter) - ) - ) - <> command - "rm" - (info - (Rm <$> rmParser <**> helper) - ( progDesc "Remove a GHC/cabal/HLS/stack 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") - ) - <> 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 )) - ) - <> command - "prefetch" - (info - ( (Prefetch - <$> prefetchP - ) <**> helper - ) - (progDesc "Prefetch assets" - <> footerDoc ( Just $ text prefetchFooter )) - ) - <> command - "gc" - (info - ( (GC - <$> gcP - ) <**> helper - ) - (progDesc "Garbage collection" - <> footerDoc ( Just $ text gcFooter )) - ) - <> 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) - ) - ) - <> command - "config" - ( Config - <$> info (configP <**> helper) - (progDesc "Show or set config" <> footerDoc (Just $ text configFooter)) - ) - <> commandGroup "Other commands:" - <> hidden - ) - <|> subparser - ( command - "install-cabal" - (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:" - <> hidden - ) - - 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/cabal/hls/stack).|] - - 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/cabal/hls/stack).|] - - unsetFooter :: String - unsetFooter = [s|Discussion: - Unsets the currently active GHC or cabal version.|] - - 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/cabal/hls/stack).|] - - 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.|] - - 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/" directory. - For cabal/stack/hls this the binary usually at "~/.ghcup/bin/-". - -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|] - - 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|] - - gcFooter :: String - gcFooter = [s|Discussion: - Performs garbage collection. If no switches are specified, does nothing.|] - -configFooter :: String -configFooter = [s|Examples: - -# show current config -ghcup config - -# initialize config -ghcup config init - -# set configuration pair -ghcup config |] - -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 (Just GHC) <**> helper) - ( progDesc "Install GHC" - <> footerDoc (Just $ text installGHCFooter) - ) - ) - <> command - "cabal" - ( InstallCabal - <$> info - (installOpts (Just Cabal) <**> helper) - ( progDesc "Install Cabal" - <> footerDoc (Just $ text installCabalFooter) - ) - ) - <> command - "hls" - ( InstallHLS - <$> info - (installOpts (Just HLS) <**> helper) - ( progDesc "Install haskell-language-server" - <> footerDoc (Just $ text installHLSFooter) - ) - ) - <> 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: - # install recommended HLS - ghcup install hls|] - - installStackFooter :: String - installStackFooter = [s|Discussion: - Installs stack binaries into "~/.ghcup/bin" - -Examples: - # install recommended Stack - ghcup install stack|] - - 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/-". - -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|] - - -installOpts :: Maybe Tool -> Parser InstallOptions -installOpts tool = - (\p (u, v) b is f -> InstallOptions v p u b is f) - <$> 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 - (option - (eitherReader bindistParser) - (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help - "Install the specified version from this bindist" - ) - ) - <*> (Just <$> toolVersionArgument Nothing tool) - ) - <|> 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") - - - -setParser :: Parser (Either SetCommand SetOptions) -setParser = - (Left <$> subparser - ( command - "ghc" - ( SetGHC - <$> info - (setOpts (Just GHC) <**> helper) - ( progDesc "Set GHC version" - <> footerDoc (Just $ text setGHCFooter) - ) - ) - <> command - "cabal" - ( SetCabal - <$> info - (setOpts (Just Cabal) <**> helper) - ( progDesc "Set Cabal version" - <> footerDoc (Just $ text setCabalFooter) - ) - ) - <> command - "hls" - ( SetHLS - <$> info - (setOpts (Just HLS) <**> helper) - ( progDesc "Set haskell-language-server version" - <> footerDoc (Just $ text setHLSFooter) - ) - ) - <> command - "stack" - ( SetStack - <$> info - (setOpts (Just Stack) <**> helper) - ( progDesc "Set stack version" - <> footerDoc (Just $ text setStackFooter) - ) - ) - ) - ) - <|> (Right <$> setOpts Nothing) - 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.|] - - setStackFooter :: String - setStackFooter = [s|Discussion: - Sets the the current Stack version.|] - - setHLSFooter :: String - setHLSFooter = [s|Discussion: - Sets the the current haskell-language-server version.|] - -unsetParser :: Parser UnsetCommand -unsetParser = - (subparser - ( command - "ghc" - ( UnsetGHC - <$> info - (unsetOpts <**> helper) - ( progDesc "Unset GHC version" - <> footerDoc (Just $ text unsetGHCFooter) - ) - ) - <> command - "cabal" - ( UnsetCabal - <$> info - (unsetOpts <**> helper) - ( progDesc "Unset Cabal version" - <> footerDoc (Just $ text unsetCabalFooter) - ) - ) - <> command - "hls" - ( UnsetHLS - <$> info - (unsetOpts <**> helper) - ( progDesc "Unset haskell-language-server version" - <> footerDoc (Just $ text unsetHLSFooter) - ) - ) - <> command - "stack" - ( UnsetStack - <$> info - (unsetOpts <**> helper) - ( progDesc "Unset stack version" - <> footerDoc (Just $ text unsetStackFooter) - ) - ) - ) - ) - where - unsetGHCFooter :: String - unsetGHCFooter = [s|Discussion: - Unsets the the current GHC version. That means there won't - be a ~/.ghcup/bin/ghc anymore.|] - - unsetCabalFooter :: String - unsetCabalFooter = [s|Discussion: - Unsets the the current Cabal version.|] - - unsetStackFooter :: String - unsetStackFooter = [s|Discussion: - Unsets the the current Stack version.|] - - unsetHLSFooter :: String - unsetHLSFooter = [s|Discussion: - Unsets the the current haskell-language-server version.|] - - -setOpts :: Maybe Tool -> Parser SetOptions -setOpts tool = SetOptions <$> - (fromMaybe SetRecommended <$> - optional (setVersionArgument (Just ListInstalled) tool)) - -unsetOpts :: Parser UnsetOptions -unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE")) - -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/set/available 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 (Just GHC) <**> helper) (progDesc "Remove GHC version")) - <> command - "cabal" - ( RmCabal - <$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper) - (progDesc "Remove Cabal version") - ) - <> command - "hls" - ( RmHLS - <$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper) - (progDesc "Remove haskell-language-server version") - ) - <> 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 - - -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 - "stack" -> Right Stack - e -> Left e - ) - ) - (short 't' <> long "tool" <> metavar "" <> help - "Open changelog for given tool (default: ghc)" - ) - ) - <*> optional (toolVersionArgument Nothing Nothing) - -compileP :: Parser CompileCommand -compileP = subparser - ( command - "ghc" - ( CompileGHC - <$> info - (ghcCompileOpts <**> helper) - ( progDesc "Compile GHC from source" - <> footerDoc (Just $ text compileFooter) - ) - ) - <> command - "hls" - ( CompileHLS - <$> info - (hlsCompileOpts <**> helper) - ( progDesc "Compile HLS from source" - <> footerDoc (Just $ text compileHLSFooter) - ) - ) - ) - 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: - # compile from known version - ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 - # compile from git commit/reference - ghcup compile ghc -j 4 -g master -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|] - - compileHLSFooter = [s|Discussion: - Compiles and installs the specified HLS version. - The last argument is a list of GHC versions to compile for. - These need to be available in PATH prior to compilation. - -Examples: - ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|] - -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") - -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/" 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|] - - -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") - ) - ) - -gcP :: Parser GCOptions -gcP = - GCOptions - <$> - switch - (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'") - <*> - switch - (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions") - <*> - switch - (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)") - <*> - switch - (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version") - <*> - switch - (short 'c' <> long "cache" <> help "GC the GHCup cache") - <*> - switch - (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") - - -ghcCompileOpts :: Parser GHCCompileOptions -ghcCompileOpts = - GHCCompileOptions - <$> ((Left <$> option - (eitherReader - (first (const "Not a valid version") . version . T.pack) - ) - (short 'v' <> long "version" <> metavar "VERSION" <> help - "The tool version to compile" - ) - ) <|> - (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)")) - ))) - <*> option - (eitherReader - (\x -> - (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") - ) - ) - ( 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 - str - (short 'c' <> long "config" <> metavar "CONFIG" <> help - "Absolute path to build config file" - ) - ) - <*> optional - (option - str - (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help - "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" - ) - ) - <*> 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" - ) - <*> 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" - ) - ) - -hlsCompileOpts :: Parser HLSCompileOptions -hlsCompileOpts = - HLSCompileOptions - <$> ((Left <$> option - (eitherReader - (first (const "Not a valid version") . version . T.pack) - ) - (short 'v' <> long "version" <> metavar "VERSION" <> help - "The tool version to compile" - ) - ) <|> - (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)")) - ))) - <*> optional - (option - (eitherReader (readEither @Int)) - (short 'j' <> long "jobs" <> metavar "JOBS" <> help - "How many jobs to use for make" - ) - ) - <*> flag - False - True - (long "set" <> help - "Set as active version after install" - ) - <*> 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 - (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" - ) - ) - <*> optional - (option - str - (long "cabal-project" <> metavar "CABAL_PROJECT" <> help - "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over." - ) - ) - <*> optional - (option - (eitherReader absolutePathParser) - (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help - "Absolute path to a cabal.project.local to be used for the build. Will be copied over." - ) - ) - <*> optional - (option - (eitherReader absolutePathParser) - (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help - "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" - ) - ) - <*> some (toolVersionArgument Nothing (Just GHC)) - - -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 :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion -toolVersionArgument criteria tool = - argument (eitherReader toolVersionEither) - (metavar (mv tool) - <> completer (tagCompleter (fromMaybe GHC tool) []) - <> foldMap (completer . versionCompleter criteria) tool) - where - mv (Just GHC) = "GHC_VERSION|TAG" - mv (Just HLS) = "HLS_VERSION|TAG" - mv _ = "VERSION|TAG" - - -setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion -setVersionArgument criteria tool = - argument (eitherReader setEither) - (metavar "VERSION|TAG|next" - <> completer (tagCompleter (fromMaybe GHC tool) ["next"]) - <> foldMap (completer . versionCompleter criteria) tool) - where - setEither s' = - parseSet s' - <|> second SetToolTag (tagEither s') - <|> second SetToolVersion (tVersionEither s') - parseSet s' = case fmap toLower s' of - "next" -> Right SetNext - 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) - - -tagCompleter :: Tool -> [String] -> Completer -tagCompleter tool add = listIOCompleter $ do - dirs' <- liftIO getAllDirs - let loggerConfig = LoggerConfig - { lcPrintDebug = False - , consoleOutter = mempty - , fileOutter = mempty - , fancyColors = False - } - let appState = LeanAppState - (Settings True False Never Curl False GHCupURL True GPGNone False) - dirs' - defaultKeyBindings - loggerConfig - - mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF - case mGhcUpInfo of - VRight ghcupInfo -> do - let allTags = filter (\t -> t /= Old) - $ join - $ fmap _viTags - $ M.elems - $ availableToolVersions (_ghcupDownloads ghcupInfo) tool - pure $ nub $ (add ++) $ fmap tagToString allTags - VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add) - - -versionCompleter :: Maybe ListCriteria -> Tool -> Completer -versionCompleter criteria tool = listIOCompleter $ do - dirs' <- liftIO getAllDirs - let loggerConfig = LoggerConfig - { lcPrintDebug = False - , consoleOutter = mempty - , fileOutter = mempty - , fancyColors = False - } - let settings = Settings True False Never Curl False GHCupURL True GPGNone False - let leanAppState = LeanAppState - settings - dirs' - defaultKeyBindings - loggerConfig - mpFreq <- flip runReaderT leanAppState . runE $ platformRequest - mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF - forFold mpFreq $ \pfreq -> do - forFold mGhcUpInfo $ \ghcupInfo -> do - let appState = AppState - settings - dirs' - defaultKeyBindings - ghcupInfo - pfreq - loggerConfig - - runEnv = flip runReaderT appState - - installedVersions <- runEnv $ listVersions (Just tool) criteria - return $ T.unpack . prettyVer . lVer <$> installedVersions - - -versionParser :: Parser GHCTargetVersion -versionParser = option - (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 - ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of - Right x -> Right (Base x) - Left _ -> Left $ "Invalid PVP version for base " <> ver' - other -> Left $ "Unknown tag " <> other - - -tVersionEither :: String -> Either String GHCTargetVersion -tVersionEither = - first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack - - -toolVersionEither :: String -> Either String ToolVersion -toolVersionEither s' = - second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s') - - -toolParser :: String -> Either String Tool -toolParser s' | t == T.pack "ghc" = Right GHC - | t == T.pack "cabal" = Right Cabal - | t == T.pack "hls" = Right HLS - | t == T.pack "stack" = Right Stack - | 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 - | t == T.pack "available" = Right ListAvailable - | 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') - -gpgParser :: String -> Either String GPGSetting -gpgParser s' | t == T.pack "strict" = Right GPGStrict - | t == T.pack "lax" = Right GPGLax - | t == T.pack "none" = Right GPGNone - | otherwise = Left ("Unknown gpg setting 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 - ] - - -bindistParser :: String -> Either String URI -bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString - -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." - -absolutePathParser :: FilePath -> Either String FilePath -absolutePathParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid absolute filepath." - toSettings :: Options -> IO (Settings, KeyBindings) toSettings options = do noColor <- isJust <$> lookupEnv "NO_COLOR" @@ -1620,55 +102,7 @@ toSettings options = do , bShowAllTools = fromMaybe bShowAllTools kShowAllTools } -updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings -updateSettings config settings = do - settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config - pure $ mergeConf settings' settings - 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 - gpgSetting' = fromMaybe gpgSetting uGPGSetting - in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor -upgradeOptsP :: Parser UpgradeOpts -upgradeOptsP = - flag' - UpgradeInplace - (short 'i' <> long "inplace" <> help - "Upgrade ghcup in-place (wherever it's at)" - ) - <|> ( UpgradeAt - <$> option - str - (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{..} <- do - dirs <- liftIO getAllDirs - let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False) - dirs - defaultKeyBindings - flip runReaderT settings $ executeOut "git" ["describe"] Nothing - case _exitCode of - ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut - ExitFailure _ -> pure numericVer - ) - ) plan_json :: String plan_json = $( do @@ -1677,12 +111,9 @@ plan_json = $( do c <- B.readFile fp (Just res) <- pure $ decodeStrict' @Value c pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res)) - when (not . null $ fp ) $ qAddDependentFile fp + unless (null fp) $ qAddDependentFile fp pure . LitE . StringL $ c) -formatConfig :: UserSettings -> String -formatConfig settings - = UTF8.toString . Y.encode1Strict $ settings main :: IO () main = do @@ -1692,8 +123,7 @@ main = do void enableAnsiSupport let versionHelp = infoOption - ( ("The GHCup Haskell installer, version " <>) - (head . lines $ describe_result) + ( "The GHCup Haskell installer, version " <> (head . lines $ describe_result) ) (long "version" <> help "Show version" <> hidden) let planJson = infoOption @@ -1737,9 +167,8 @@ Report bugs at |] (settings, keybindings) <- toSettings opt - -- logger interpreter - logfile <- flip runReaderT dirs initGHCupFileLogging + logfile <- runReaderT initGHCupFileLogging dirs no_color <- isJust <$> lookupEnv "NO_COLOR" let loggerConfig = LoggerConfig { lcPrintDebug = verbose settings @@ -1773,8 +202,7 @@ Report bugs at |] ghcupInfo <- ( flip runReaderT leanAppstate . runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError] - $ liftE - $ getDownloadsF + $ liftE getDownloadsF ) >>= \case VRight r -> pure r @@ -1784,7 +212,7 @@ Report bugs at |] exitWith (ExitFailure 2) let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig - race_ (liftIO $ flip runReaderT s' cleanupTrash) + race_ (liftIO $ runReaderT cleanupTrash s') (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually")) case optCommand of @@ -1798,11 +226,11 @@ Report bugs at |] Interactive -> pure () #endif _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case - Nothing -> flip runReaderT s' checkForUpdates + Nothing -> runReaderT checkForUpdates s' Just _ -> pure () -- TODO: always run for windows - (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case + siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case VRight _ -> pure () VLeft e -> do runLogger @@ -1820,541 +248,12 @@ Report bugs at |] #endif runAppState action' = do s' <- liftIO appState - flip runReaderT s' action' + runReaderT action' s' - - - ------------------------- - -- Effect interpreters -- - ------------------------- - - - let runInstTool' appstate' mInstPlatform = - flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) - . runResourceT - . runE - @'[ AlreadyInstalled - , UnknownArchive - , ArchiveResult - , FileDoesNotExistError - , CopyError - , NotInstalled - , DirNotEmpty - , NoDownload - , NotInstalled - , BuildFailed - , TagNotFound - , DigestError - , GPGError - , DownloadFailed - , TarDirDoesNotExist - , NextVerNotFound - , NoToolVersionSet - , FileAlreadyExistsError - , ProcessError - ] - - let runInstTool mInstPlatform action' = do - s' <- liftIO appState - runInstTool' s' mInstPlatform action' - - let - runLeanSetGHC = - runLeanAppState - . runE - @'[ FileDoesNotExistError - , NotInstalled - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] - - runSetGHC = - runAppState - . runE - @'[ FileDoesNotExistError - , NotInstalled - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] - - runUnsetGHC = - runLeanAppState - . runE - @'[ NotInstalled ] - - let - runLeanSetCabal = - runLeanAppState - . runE - @'[ NotInstalled - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] - - runSetCabal = - runAppState - . runE - @'[ NotInstalled - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] - - let - runSetHLS = - runAppState - . runE - @'[ NotInstalled - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] - - runLeanSetHLS = - runLeanAppState - . runE - @'[ NotInstalled - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] - - let runListGHC = runAppState - - let runRm = - runAppState . runE @'[NotInstalled] - - let runNuke s' = - flip runReaderT s' . runE @'[NotInstalled] - - let runDebugInfo = - runAppState - . runE - @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] - - let runCompileGHC = - runAppState - . runResourceT - . runE - @'[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , NotInstalled - , DirNotEmpty - , ArchiveResult - , FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , ProcessError - , CopyError - , BuildFailed - ] - - let runCompileHLS = - runAppState - . runResourceT - . runE - @'[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , TagNotFound - , NextVerNotFound - , NoToolVersionSet - , NotInstalled - , DirNotEmpty - , ArchiveResult - ] - - let - runLeanWhereIs = - -- Don't use runLeanAppState here, which is disabled on windows. - -- This is the only command on all platforms that doesn't need full appstate. - flip runReaderT leanAppstate - . runE - @'[ NotInstalled - , NoToolVersionSet - , NextVerNotFound - , TagNotFound - ] - - runWhereIs = - runAppState - . runE - @'[ NotInstalled - , NoToolVersionSet - , NextVerNotFound - , TagNotFound - ] - - let runUpgrade = - runAppState - . runResourceT - . runE - @'[ DigestError - , GPGError - , NoDownload - , NoUpdate - , FileDoesNotExistError - , CopyError - , DownloadFailed - ] - - let runPrefetch = - runAppState - . runResourceT - . runE - @'[ TagNotFound - , NextVerNotFound - , NoToolVersionSet - , NoDownload - , DigestError - , GPGError - , DownloadFailed - , JSONError - , FileDoesNotExistError - ] - - let runGC = - runAppState - . runResourceT - . runE - @'[ NotInstalled - ] - - - ----------------------- - -- Command functions -- - ----------------------- - - let installGHC InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBin - (_tvVersion v) - isolateDir - forceInstall - 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 - forceInstall - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi - ) - >>= \case - VRight vi -> do - runLogger $ logInfo "GHC installation successful" - forM_ (_viPostInstall =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft (V (AlreadyInstalled _ v)) -> do - runLogger $ logWarn $ - "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'" - pure ExitSuccess - VLeft (V (DirNotEmpty fp)) -> do - runLogger $ logWarn $ - "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless." - pure $ ExitFailure 3 - VLeft err@(V (BuildFailed tmpdir _)) -> do - case keepDirs settings of - Never -> runLogger $ (logError $ T.pack $ prettyShow err) - _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <> - "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 - 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 - runLogger $ logInfo "Cabal installation successful" - forM_ (_viPostInstall =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft (V (AlreadyInstalled _ v)) -> do - runLogger $ logWarn $ - "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'" - pure ExitSuccess - VLeft (V (FileAlreadyExistsError fp)) -> do - runLogger $ logWarn $ - "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." - pure $ ExitFailure 3 - VLeft e -> do - runLogger $ do - logError $ T.pack $ prettyShow e - 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 - forceInstall - 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 - forceInstall - pure vi - ) - >>= \case - VRight vi -> do - runLogger $ logInfo "HLS installation successful" - forM_ (_viPostInstall =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft (V (AlreadyInstalled _ v)) -> do - runLogger $ logWarn $ - "HLS ver " - <> prettyVer v - <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force " - <> prettyVer v - <> "'" - pure ExitSuccess - VLeft (V (FileAlreadyExistsError fp)) -> do - runLogger $ logWarn $ - "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." - pure $ ExitFailure 3 - VLeft e -> do - runLogger $ do - logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir - pure $ ExitFailure 4 - - let installStack InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBin - (_tvVersion v) - isolateDir - forceInstall - 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 - forceInstall - pure vi - ) - >>= \case - VRight vi -> do - runLogger $ logInfo "Stack installation successful" - forM_ (_viPostInstall =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft (V (AlreadyInstalled _ v)) -> do - runLogger $ logWarn $ - "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'" - pure ExitSuccess - VLeft (V (FileAlreadyExistsError fp)) -> do - runLogger $ logWarn $ - "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." - pure $ ExitFailure 3 - VLeft e -> do - runLogger $ do - logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir - 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 - VRight GHCTargetVersion{..} -> do - runLogger - $ logInfo $ - "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget - pure ExitSuccess - VLeft e -> do - 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 - VRight GHCTargetVersion{..} -> do - runLogger - $ logInfo $ - "Cabal " <> prettyVer _tvVersion <> " successfully set as default version" - pure ExitSuccess - VLeft e -> do - 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 - VRight GHCTargetVersion{..} -> do - runLogger - $ logInfo $ - "HLS " <> prettyVer _tvVersion <> " successfully set as default version" - pure ExitSuccess - VLeft e -> do - 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 - ) - >>= \case - VRight GHCTargetVersion{..} -> do - runLogger - $ logInfo $ - "Stack " <> prettyVer _tvVersion <> " successfully set as default version" - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 14 - - let rmGHC' RmOptions{..} = - runRm (do - liftE $ - rmGHCVer ghcVer - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo (_tvVersion ghcVer) GHC dls) - ) - >>= \case - VRight vi -> do - forM_ (_viPostRemove =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 7 - - let rmCabal' tv = - runRm (do - liftE $ - rmCabalVer tv - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo tv Cabal dls) - ) - >>= \case - VRight vi -> do - forM_ (_viPostRemove =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 15 - - let rmHLS' tv = - runRm (do - liftE $ - rmHLSVer tv - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo tv HLS dls) - ) - >>= \case - VRight vi -> do - forM_ (_viPostRemove =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 15 - - let rmStack' tv = - runRm (do - liftE $ - rmStackVer tv - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo tv Stack dls) - ) - >>= \case - VRight vi -> do - forM_ (_viPostRemove =<< vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 15 + ----------------- + -- Run command -- + ----------------- res <- case optCommand of #if defined(BRICK) @@ -2362,746 +261,28 @@ Report bugs at |] s' <- appState liftIO $ brickMain s' >> pure ExitSuccess #endif - Install (Right iopts) -> do - 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 - Install (Left (InstallStack iopts)) -> installStack iopts - InstallCabalLegacy iopts -> do - runLogger (logWarn "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.") - installCabal iopts - - Set (Right sopts) -> do - 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 - Set (Left (SetStack sopts)) -> setStack' sopts - - UnSet (UnsetGHC (UnsetOptions triple)) -> runUnsetGHC (unsetGHC triple) - >>= \case - VRight _ -> do - runLogger $ logInfo "GHC successfully unset" - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 14 - UnSet (UnsetCabal (UnsetOptions _)) -> do - runAppState unsetCabal - runLogger $ logInfo "Cabal successfully unset" - pure ExitSuccess - UnSet (UnsetHLS (UnsetOptions _)) -> do - runAppState unsetHLS - runLogger $ logInfo "HLS successfully unset" - pure ExitSuccess - UnSet (UnsetStack (UnsetOptions _)) -> do - runAppState unsetStack - runLogger $ logInfo "Stack successfully unset" - pure ExitSuccess - - List ListOptions {..} -> - runListGHC (do - l <- listVersions loTool lCriteria - liftIO $ printListResult no_color lRawFormat l - pure ExitSuccess - ) - - Rm (Right rmopts) -> do - 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 - Rm (Left (RmStack rmopts)) -> rmStack' rmopts - - DInfo -> - do runDebugInfo $ liftE getDebugInfo - >>= \case - VRight dinfo -> do - putStrLn $ prettyDebugInfo dinfo - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 8 - - Compile (CompileHLS HLSCompileOptions { .. }) -> do - runCompileHLS (do - case targetHLS of - Left targetVer -> do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo targetVer HLS dls - forM_ (_viPreCompile =<< vi) $ \msg -> do - lift $ logInfo msg - lift $ logInfo - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - Right _ -> pure () - ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) - targetVer <- liftE $ compileHLS - targetHLS - ghcs - jobs - ovewrwiteVer - isolateDir - cabalProject - cabalProjectLocal - patchDir - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo targetVer HLS dls - when setCompile $ void $ liftE $ - setHLS targetVer - pure (vi, targetVer) - ) - >>= \case - VRight (vi, tv) -> do - runLogger $ logInfo - "HLS successfully compiled and installed" - forM_ (_viPostInstall =<< vi) $ \msg -> - runLogger $ logInfo msg - putStr (T.unpack $ prettyVer tv) - pure ExitSuccess - VLeft err@(V (BuildFailed tmpdir _)) -> do - case keepDirs settings of - Never -> runLogger $ logError $ T.pack $ prettyShow err - _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <> - "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 9 - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 9 - Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do - runLogger $ logError "Hadrian cross compile support is not yet implemented!" - pure $ ExitFailure 9 - Compile (CompileGHC GHCCompileOptions {..}) -> - runCompileGHC (do - case targetGhc of - Left targetVer -> do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo targetVer GHC dls - forM_ (_viPreCompile =<< vi) $ \msg -> do - lift $ logInfo msg - lift $ logInfo - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - Right _ -> pure () - targetVer <- liftE $ compileGHC - (first (GHCTargetVersion crossTarget) targetGhc) - ovewrwiteVer - bootstrapGhc - jobs - buildConfig - patchDir - addConfArgs - buildFlavour - hadrian - isolateDir - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo (_tvVersion targetVer) GHC dls - when setCompile $ void $ liftE $ - setGHC targetVer SetGHCOnly - pure (vi, targetVer) - ) - >>= \case - VRight (vi, tv) -> do - runLogger $ logInfo - "GHC successfully compiled and installed" - forM_ (_viPostInstall =<< vi) $ \msg -> - runLogger $ logInfo msg - putStr (T.unpack $ tVerToText tv) - pure ExitSuccess - VLeft (V (AlreadyInstalled _ v)) -> do - runLogger $ logWarn $ - "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'" - pure ExitSuccess - VLeft (V (DirNotEmpty fp)) -> do - runLogger $ logWarn $ - "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless." - pure $ ExitFailure 3 - VLeft err@(V (BuildFailed tmpdir _)) -> do - case keepDirs settings of - Never -> runLogger $ logError $ T.pack $ prettyShow err - _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <> - "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 9 - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 9 - - Config InitConfig -> do - path <- getConfigFilePath - writeFile path $ formatConfig $ fromSettings settings (Just keybindings) - runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path - pure ExitSuccess - - Config ShowConfig -> do - putStrLn $ formatConfig $ fromSettings settings (Just keybindings) - pure ExitSuccess - - Config (SetConfig k v) -> do - case v of - "" -> do - runLogger $ logError "Empty values are not allowed" - pure $ ExitFailure 55 - _ -> do - r <- runE @'[JSONError] $ do - settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings - path <- liftIO getConfigFilePath - liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings) - runLogger $ logDebug $ T.pack $ show settings' - pure () - - case r of - VRight _ -> pure ExitSuccess - VLeft (V (JSONDecodeError e)) -> do - runLogger $ logError $ "Error decoding config: " <> T.pack e - pure $ ExitFailure 65 - VLeft _ -> pure $ ExitFailure 65 - - 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 - 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 - 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 - - Upgrade uOpts force' -> do - target <- case uOpts of - UpgradeInplace -> Just <$> liftIO getExecutablePath - (UpgradeAt p) -> pure $ Just p - UpgradeGHCupDir -> pure (Just (binDir "ghcup" <> exeExt)) - - 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 - runLogger $ logInfo $ - "Successfully upgraded GHCup to version " <> pretty_v - forM_ (_viPostInstall vi) $ \msg -> - runLogger $ logInfo msg - pure ExitSuccess - VLeft (V NoUpdate) -> do - runLogger $ logWarn "No GHCup update available" - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 11 - - ToolRequirements -> do - s' <- appState - flip runReaderT s' - $ (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 - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 12 - - ChangeLog ChangeLogOptions{..} -> do - GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo - 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 $ - "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver' - ) - pure ExitSuccess - Just uri -> do - s' <- appState - pfreq <- flip runReaderT s' getPlatformReq - let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri - cmd = case _rPlatform pfreq of - Darwin -> "open" - Linux _ -> "xdg-open" - FreeBSD -> "xdg-open" - Windows -> "start" - - if clOpen - then do - flip runReaderT s' $ - exec cmd - [T.unpack $ decUTF8Safe $ serializeURIRef' uri] - Nothing - Nothing - >>= \case - Right _ -> pure ExitSuccess - Left e -> logError (T.pack $ prettyShow e) - >> pure (ExitFailure 13) - else putStrLn uri' >> pure ExitSuccess - - Nuke -> do - s' <- liftIO appState - void $ liftIO $ evaluate $ force s' - runNuke s' (do - 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 - - lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀" - lift $ logInfo "Nuking in 3...2...1" - - lInstalled <- lift $ listVersions Nothing (Just ListInstalled) - - forM_ lInstalled (liftE . rmTool) - - lift rmGhcupDirs - - ) >>= \case - VRight leftOverFiles - | null leftOverFiles -> do - runLogger $ logInfo "Nuclear Annihilation complete!" - pure ExitSuccess - | otherwise -> do - runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually." - forM_ leftOverFiles putStrLn - pure ExitSuccess - - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 15 - 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 - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 15 - GC GCOptions{..} -> - runGC (do - when gcOldGHC rmOldGHC - lift $ when gcProfilingLibs rmProfilingLibs - lift $ when gcShareDir rmShareDir - lift $ when gcHLSNoGHC rmHLSNoGHC - lift $ when gcCache rmCache - lift $ when gcTmp rmTmp - ) >>= \case - VRight _ -> do - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 27 - + Install installCommand -> install installCommand settings appState runLogger + InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger + Set setCommand -> set setCommand runAppState runLeanAppState runLogger + UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger + List lo -> list lo no_color runAppState + Rm rmCommand -> rm rmCommand runAppState runLogger + DInfo -> dinfo runAppState runLogger + Compile compileCommand -> compile compileCommand settings runAppState runLogger + Config configCommand -> config configCommand settings keybindings runLogger + Whereis whereisOptions + whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger + Upgrade uOpts force' -> upgrade uOpts force' runAppState runLogger + ToolRequirements -> toolRequirements runAppState runLogger + ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger + Nuke -> nuke appState runLogger + Prefetch pfCom -> prefetch pfCom runAppState runLogger + GC gcOpts -> gc gcOpts runAppState runLogger case res of ExitSuccess -> pure () ef@(ExitFailure _) -> exitWith ef - pure () -fromVersion :: ( HasLog env - , MonadFail m - , MonadReader env m - , HasGHCupInfo env - , HasDirs env - , MonadThrow m - , MonadIO m - , MonadCatch m - ) - => Maybe ToolVersion - -> Tool - -> Excepts - '[ TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion tv = fromVersion' (toSetToolVer tv) - -fromVersion' :: ( HasLog env - , MonadFail m - , MonadReader env m - , HasGHCupInfo env - , HasDirs env - , MonadThrow m - , MonadIO m - , MonadCatch m - ) - => SetToolVersion - -> Tool - -> Excepts - '[ TagNotFound - , NextVerNotFound - , NoToolVersionSet - ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion' SetRecommended tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool - ?? TagNotFound Recommended tool -fromVersion' (SetToolVersion v) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo (_tvVersion v) tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool pvpIn dls) >>= \case - Just (pvp_, vi') -> do - v' <- lift $ pvpToVersion pvp_ - when (v' /= (_tvVersion v)) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion (_tvTarget v) v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolTag Latest) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool -fromVersion' (SetToolTag Recommended) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool -fromVersion' (SetToolTag (Base pvp'')) GHC = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC -fromVersion' SetNext tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - 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 - Stack -> do - set <- stackSet !? NoToolVersionSet tool - stacks <- rights <$> lift getInstalledStacks - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ stacks) ?? NoToolVersionSet tool - GHCup -> fail "GHCup cannot be set" - let vi = getVersionInfo (_tvVersion next) tool dls - pure (next, vi) -fromVersion' (SetToolTag t') tool = - throwE $ TagNotFound t' tool - - -printListResult :: Bool -> Bool -> [ListResult] -> IO () -printListResult no_color raw lr = do - - 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 = "" - - let - rows = - (\x -> if raw - then x - else [color Green "", "Tool", "Version", "Tags", "Notes"] : x - ) - . fmap - (\ListResult {..} -> - let marks = if -#if defined(IS_WINDOWS) - | lSet -> (color Green "IS") - | lInstalled -> (color Green "I ") - | otherwise -> (color Red "X ") -#else - | lSet -> (color Green "✔✔") - | lInstalled -> (color Green "✓ ") - | otherwise -> (color Red "✗ ") -#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 - ) - ] - ) - $ 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 - where - - 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 - , MonadCatch m - , HasLog env - , MonadThrow m - , MonadIO m - , MonadFail m - ) - => m () -checkForUpdates = do - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - lInstalled <- listVersions Nothing (Just ListInstalled) - let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled - - forM_ (getLatest dls GHCup) $ \(l, _) -> do - (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer - when (l > ghc_ver) - $ logWarn $ - "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'" - - forM_ (getLatest dls GHC) $ \(l, _) -> do - let mghc_ver = latestInstalled GHC - forM mghc_ver $ \ghc_ver -> - when (l > ghc_ver) - $ logWarn $ - "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) - $ logWarn $ - "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) - $ logWarn $ - "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'" - - forM_ (getLatest dls Stack) $ \(l, _) -> do - let mstack_ver = latestInstalled Stack - forM mstack_ver $ \stack_ver -> - when (l > stack_ver) - $ logWarn $ - "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'" - - -prettyDebugInfo :: DebugInfo -> String -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 diff --git a/ghcup.cabal b/ghcup.cabal index bdbc367..d47941f 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -172,6 +172,23 @@ library executable ghcup main-is: Main.hs + other-modules: GHCup.OptParse.Install + GHCup.OptParse.Common + GHCup.OptParse.Set + GHCup.OptParse.UnSet + GHCup.OptParse.Rm + GHCup.OptParse.Compile + GHCup.OptParse.Config + GHCup.OptParse.Whereis + GHCup.OptParse.List + GHCup.OptParse.DInfo + GHCup.OptParse.Upgrade + GHCup.OptParse.ToolRequirements + GHCup.OptParse.ChangeLog + GHCup.OptParse.Nuke + GHCup.OptParse.Prefetch + GHCup.OptParse.GC + GHCup.OptParse hs-source-dirs: app/ghcup default-language: Haskell2010 default-extensions: