Refactor app Main
This commit is contained in:
parent
09d2a1e815
commit
4c7c9ab62e
GPG Key ID:
3786C5262ECB4A3F
309
app/ghcup/GHCup/OptParse.hs
Normal file
309
app/ghcup/GHCup/OptParse.hs
Normal file
@ -0,0 +1,309 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# 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
|
||||||
|
)
|
||||||
151
app/ghcup/GHCup/OptParse/ChangeLog.hs
Normal file
151
app/ghcup/GHCup/OptParse/ChangeLog.hs
Normal file
@ -0,0 +1,151 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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
|
||||||
520
app/ghcup/GHCup/OptParse/Common.hs
Normal file
520
app/ghcup/GHCup/OptParse/Common.hs
Normal file
@ -0,0 +1,520 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# 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'
|
||||||
|
[ (\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
|
||||||
|
|
||||||
|
|
||||||
|
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 (\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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-----------------
|
||||||
|
--[ 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
|
||||||
|
(\(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
|
||||||
|
|
||||||
|
|
||||||
|
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 <> "'"
|
||||||
518
app/ghcup/GHCup/OptParse/Compile.hs
Normal file
518
app/ghcup/GHCup/OptParse/Compile.hs
Normal file
@ -0,0 +1,518 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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
|
||||||
|
, 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
|
||||||
169
app/ghcup/GHCup/OptParse/Config.hs
Normal file
169
app/ghcup/GHCup/OptParse/Config.hs
Normal file
@ -0,0 +1,169 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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 <key> <value> configuration pair
|
||||||
|
ghcup config <key> <value>|]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-----------------
|
||||||
|
--[ 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
|
||||||
120
app/ghcup/GHCup/OptParse/DInfo.hs
Normal file
120
app/ghcup/GHCup/OptParse/DInfo.hs
Normal file
@ -0,0 +1,120 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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
|
||||||
144
app/ghcup/GHCup/OptParse/GC.hs
Normal file
144
app/ghcup/GHCup/OptParse/GC.hs
Normal file
@ -0,0 +1,144 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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
|
||||||
465
app/ghcup/GHCup/OptParse/Install.hs
Normal file
465
app/ghcup/GHCup/OptParse/Install.hs
Normal file
@ -0,0 +1,465 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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/<ghcver>" directory
|
||||||
|
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
# install recommended GHC
|
||||||
|
ghcup install ghc
|
||||||
|
|
||||||
|
# install latest GHC
|
||||||
|
ghcup install ghc latest
|
||||||
|
|
||||||
|
# install GHC 8.10.2
|
||||||
|
ghcup install ghc 8.10.2
|
||||||
|
|
||||||
|
# install GHC head fedora bindist
|
||||||
|
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
|
||||||
|
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
272
app/ghcup/GHCup/OptParse/List.hs
Normal file
272
app/ghcup/GHCup/OptParse/List.hs
Normal file
@ -0,0 +1,272 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# 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 "<ghc|cabal|hls|stack>" <> help
|
||||||
|
"Tool to list versions for. Default is all"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
<*> optional
|
||||||
|
(option
|
||||||
|
(eitherReader criteriaParser)
|
||||||
|
( short 'c'
|
||||||
|
<> long "show-criteria"
|
||||||
|
<> metavar "<installed|set|available>"
|
||||||
|
<> 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 = 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
------------------
|
||||||
|
--[ 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
|
||||||
|
)
|
||||||
102
app/ghcup/GHCup/OptParse/Nuke.hs
Normal file
102
app/ghcup/GHCup/OptParse/Nuke.hs
Normal file
@ -0,0 +1,102 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# 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
|
||||||
220
app/ghcup/GHCup/OptParse/Prefetch.hs
Normal file
220
app/ghcup/GHCup/OptParse/Prefetch.hs
Normal file
@ -0,0 +1,220 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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"
|
||||||
|
(const 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
|
||||||
233
app/ghcup/GHCup/OptParse/Rm.hs
Normal file
233
app/ghcup/GHCup/OptParse/Rm.hs
Normal file
@ -0,0 +1,233 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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
|
||||||
|
|
||||||
347
app/ghcup/GHCup/OptParse/Set.hs
Normal file
347
app/ghcup/GHCup/OptParse/Set.hs
Normal file
@ -0,0 +1,347 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# 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)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
----------------
|
||||||
|
--[ 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/<binary>".|]
|
||||||
|
|
||||||
|
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 . ( Monad m
|
||||||
|
, MonadMask m
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, MonadFail m
|
||||||
|
)
|
||||||
|
=> Either SetCommand SetOptions
|
||||||
|
-> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
|
||||||
|
-> m (VEither eff GHCTargetVersion))
|
||||||
|
-> (forall eff . ReaderT LeanAppState 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
|
||||||
86
app/ghcup/GHCup/OptParse/ToolRequirements.hs
Normal file
86
app/ghcup/GHCup/OptParse/ToolRequirements.hs
Normal file
@ -0,0 +1,86 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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
|
||||||
204
app/ghcup/GHCup/OptParse/UnSet.hs
Normal file
204
app/ghcup/GHCup/OptParse/UnSet.hs
Normal file
@ -0,0 +1,204 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
----------------
|
||||||
|
--[ 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
|
||||||
|
)
|
||||||
|
=> UnsetCommand
|
||||||
|
-> (ReaderT LeanAppState 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
|
||||||
153
app/ghcup/GHCup/OptParse/Upgrade.hs
Normal file
153
app/ghcup/GHCup/OptParse/Upgrade.hs
Normal file
@ -0,0 +1,153 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# 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
|
||||||
320
app/ghcup/GHCup/OptParse/Whereis.hs
Normal file
320
app/ghcup/GHCup/OptParse/Whereis.hs
Normal file
@ -0,0 +1,320 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# 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/<ghcver>" directory.
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
|
||||||
|
ghcup whereis ghc 8.10.5
|
||||||
|
# outputs ~/.ghcup/ghc/8.10.5/bin/
|
||||||
|
ghcup whereis --directory ghc 8.10.5 |]
|
||||||
|
|
||||||
|
whereisCabalFooter = [s|Discussion:
|
||||||
|
Finds the location of a Cabal executable, which usually resides in
|
||||||
|
"~/.ghcup/bin/".
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
# outputs ~/.ghcup/bin/cabal-3.4.0.0
|
||||||
|
ghcup whereis cabal 3.4.0.0
|
||||||
|
# outputs ~/.ghcup/bin
|
||||||
|
ghcup whereis --directory cabal 3.4.0.0|]
|
||||||
|
|
||||||
|
whereisHLSFooter = [s|Discussion:
|
||||||
|
Finds the location of a HLS executable, which usually resides in
|
||||||
|
"~/.ghcup/bin/".
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
# outputs ~/.ghcup/bin/haskell-language-server-wrapper-1.2.0
|
||||||
|
ghcup whereis hls 1.2.0
|
||||||
|
# outputs ~/.ghcup/bin/
|
||||||
|
ghcup whereis --directory hls 1.2.0|]
|
||||||
|
|
||||||
|
whereisStackFooter = [s|Discussion:
|
||||||
|
Finds the location of a stack executable, which usually resides in
|
||||||
|
"~/.ghcup/bin/".
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
# outputs ~/.ghcup/bin/stack-2.7.1
|
||||||
|
ghcup whereis stack 2.7.1
|
||||||
|
# outputs ~/.ghcup/bin/
|
||||||
|
ghcup whereis --directory stack 2.7.1|]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
--------------
|
||||||
|
--[ 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/<ghcver>" directory.
|
||||||
|
For cabal/stack/hls this the binary usually at "~/.ghcup/bin/<tool>-<ver>".
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
|
||||||
|
ghcup whereis ghc 8.10.5
|
||||||
|
# outputs ~/.ghcup/ghc/8.10.5/bin/
|
||||||
|
ghcup whereis --directory ghc 8.10.5
|
||||||
|
# outputs ~/.ghcup/bin/cabal-3.4.0.0
|
||||||
|
ghcup whereis cabal 3.4.0.0
|
||||||
|
# outputs ~/.ghcup/bin/
|
||||||
|
ghcup whereis --directory cabal 3.4.0.0|]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
---------------------------
|
||||||
|
--[ 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
|
||||||
|
VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)
|
||||||
|
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{..}) ->
|
||||||
|
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
|
||||||
2860
app/ghcup/Main.hs
2860
app/ghcup/Main.hs
File diff suppressed because it is too large
Load Diff
17
ghcup.cabal
17
ghcup.cabal
@ -172,6 +172,23 @@ library
|
|||||||
|
|
||||||
executable ghcup
|
executable ghcup
|
||||||
main-is: Main.hs
|
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
|
hs-source-dirs: app/ghcup
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions:
|
default-extensions:
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user