Refactor app Main
This commit is contained in:
parent
09d2a1e815
commit
01956d694d
2
.gitignore
vendored
2
.gitignore
vendored
@ -13,3 +13,5 @@ TAGS
|
||||
/tmp/
|
||||
.entangled
|
||||
release/
|
||||
releases/
|
||||
site/
|
||||
|
@ -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/
|
||||
|
||||
|
@ -1,10 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
303
app/ghcup/GHCup/OptParse.hs
Normal file
303
app/ghcup/GHCup/OptParse.hs
Normal file
@ -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 "<always|errors|never>"
|
||||
<> help
|
||||
"Keep build directories? (default: errors)"
|
||||
<> hidden
|
||||
))
|
||||
<*> optional (option
|
||||
(eitherReader downloaderParser)
|
||||
( long "downloader"
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
<> metavar "<internal|curl|wget>"
|
||||
<> help
|
||||
"Downloader to use (default: internal)"
|
||||
#else
|
||||
<> metavar "<curl|wget>"
|
||||
<> help
|
||||
"Downloader to use (default: curl)"
|
||||
#endif
|
||||
<> hidden
|
||||
))
|
||||
<*> 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 "<strict|lax|none>"
|
||||
<> 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
|
||||
)
|
150
app/ghcup/GHCup/OptParse/ChangeLog.hs
Normal file
150
app/ghcup/GHCup/OptParse/ChangeLog.hs
Normal file
@ -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 "<ghc|cabal|ghcup>" <> 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
|
513
app/ghcup/GHCup/OptParse/Common.hs
Normal file
513
app/ghcup/GHCup/OptParse/Common.hs
Normal file
@ -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 <> "'"
|
517
app/ghcup/GHCup/OptParse/Compile.hs
Normal file
517
app/ghcup/GHCup/OptParse/Compile.hs
Normal file
@ -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/<ghcver>" directory
|
||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||
|
||||
This also allows building a cross-compiler. Consult the documentation
|
||||
first: <https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#configuring-the-build>
|
||||
|
||||
ENV variables:
|
||||
Various toolchain variables will be passed onto the ghc build system,
|
||||
such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
|
||||
|
||||
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
|
||||