2020-04-09 17:53:22 +00:00
{- # LANGUAGE CPP # -}
2020-01-11 20:15:05 +00:00
{- # LANGUAGE DataKinds # -}
{- # LANGUAGE TypeApplications # -}
2020-08-05 19:50:39 +00:00
{- # LANGUAGE FlexibleContexts # -}
2020-01-11 20:15:05 +00:00
{- # LANGUAGE OverloadedStrings # -}
{- # LANGUAGE TemplateHaskell # -}
{- # LANGUAGE QuasiQuotes # -}
2020-03-21 21:19:37 +00:00
{- # LANGUAGE OverloadedStrings # -}
2020-01-11 20:15:05 +00:00
{- # LANGUAGE DuplicateRecordFields # -}
module Main where
2020-07-06 20:39:16 +00:00
# if defined ( BRICK )
import BrickMain ( brickMain )
# endif
2020-01-11 20:15:05 +00:00
import GHCup
import GHCup.Download
import GHCup.Errors
2020-04-10 15:36:27 +00:00
import GHCup.Platform
import GHCup.Requirements
2020-01-11 20:15:05 +00:00
import GHCup.Types
2021-07-18 12:39:49 +00:00
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import GHCup.Utils
2020-04-17 14:56:56 +00:00
import GHCup.Utils.File
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Logger
2020-04-25 10:06:41 +00:00
import GHCup.Utils.MegaParsec
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Prelude
2020-07-04 19:49:59 +00:00
import GHCup.Utils.String.QQ
2020-01-11 20:15:05 +00:00
import GHCup.Version
2020-07-12 20:29:50 +00:00
# if ! defined ( TAR )
2020-07-04 21:33:48 +00:00
import Codec.Archive
2020-07-12 20:29:50 +00:00
# endif
2021-02-22 20:55:05 +00:00
import Control.Concurrent
2021-07-21 13:43:45 +00:00
import Control.Concurrent.Async
2021-07-15 11:32:48 +00:00
import Control.DeepSeq ( force )
import Control.Exception ( evaluate )
2020-05-15 19:53:45 +00:00
import Control.Exception.Safe
2020-04-09 17:53:22 +00:00
# if ! MIN_VERSION_base ( 4 , 13 , 0 )
import Control.Monad.Fail ( MonadFail )
# endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.Char
2020-03-09 21:21:22 +00:00
import Data.Either
2020-03-17 00:58:59 +00:00
import Data.Functor
2021-02-25 17:21:25 +00:00
import Data.List ( intercalate , nub , sort , sortBy )
2020-04-22 14:13:58 +00:00
import Data.List.NonEmpty ( NonEmpty ( ( :| ) ) )
2020-04-18 13:05:05 +00:00
import Data.Maybe
2020-01-11 20:15:05 +00:00
import Data.String.Interpolate
2020-03-17 00:58:59 +00:00
import Data.Text ( Text )
2020-04-25 10:06:41 +00:00
import Data.Versions hiding ( str )
2020-03-17 00:58:59 +00:00
import Data.Void
2020-03-17 21:58:52 +00:00
import GHC.IO.Encoding
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
2020-04-17 14:56:56 +00:00
import Language.Haskell.TH
2020-01-11 20:15:05 +00:00
import Options.Applicative hiding ( style )
2020-04-17 20:11:41 +00:00
import Options.Applicative.Help.Pretty ( text )
2020-01-11 20:15:05 +00:00
import Prelude hiding ( appendFile )
2020-04-18 18:20:18 +00:00
import Safe
2020-11-25 09:36:34 +00:00
import System.Console.Pretty hiding ( color )
import qualified System.Console.Pretty as Pretty
2020-01-11 20:15:05 +00:00
import System.Environment
import System.Exit
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO hiding ( appendFile )
2020-05-15 19:53:45 +00:00
import Text.Read hiding ( lift )
2021-03-01 23:15:03 +00:00
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-01-11 20:15:05 +00:00
import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
2021-02-25 15:13:00 +00:00
import qualified Data.Map.Strict as M
2020-01-11 20:15:05 +00:00
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
2020-03-17 00:58:59 +00:00
import qualified Text.Megaparsec as MP
2020-09-22 19:05:59 +00:00
import qualified Text.Megaparsec.Char as MPC
2020-01-11 20:15:05 +00:00
data Options = Options
{
-- global options
2020-10-24 20:03:00 +00:00
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
2020-01-11 20:15:05 +00:00
, optUrlSource :: Maybe URI
2020-10-24 20:03:00 +00:00
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
2021-07-18 21:29:09 +00:00
, optNoNetwork :: Maybe Bool
2020-01-11 20:15:05 +00:00
-- commands
, optCommand :: Command
}
data Command
2020-05-10 22:18:53 +00:00
= Install ( Either InstallCommand InstallOptions )
| InstallCabalLegacy InstallOptions
| Set ( Either SetCommand SetOptions )
2020-01-11 20:15:05 +00:00
| List ListOptions
2020-05-10 22:18:53 +00:00
| Rm ( Either RmCommand RmOptions )
2020-01-11 20:15:05 +00:00
| DInfo
| Compile CompileCommand
2021-07-12 13:40:42 +00:00
| Whereis WhereisOptions WhereisCommand
2020-04-15 11:57:44 +00:00
| Upgrade UpgradeOpts Bool
2020-04-10 15:36:27 +00:00
| ToolRequirements
2020-04-18 13:05:05 +00:00
| ChangeLog ChangeLogOptions
2021-06-18 09:31:32 +00:00
| Nuke
2020-07-06 20:39:16 +00:00
# if defined ( BRICK )
| Interactive
# endif
2021-07-19 14:49:18 +00:00
| Prefetch PrefetchCommand
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
2020-01-11 20:15:05 +00:00
| ToolTag Tag
2020-04-22 14:13:58 +00:00
prettyToolVer :: ToolVersion -> String
2021-03-01 23:15:03 +00:00
prettyToolVer ( ToolVersion v' ) = T . unpack $ tVerToText v'
2020-04-22 14:13:58 +00:00
prettyToolVer ( ToolTag t ) = show t
2021-02-25 17:21:25 +00:00
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer ( Just ( ToolVersion v' ) ) = SetToolVersion v'
toSetToolVer ( Just ( ToolTag t' ) ) = SetToolTag t'
toSetToolVer Nothing = SetRecommended
2020-01-11 20:15:05 +00:00
2020-05-10 22:18:53 +00:00
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
2020-09-20 15:57:16 +00:00
| InstallHLS InstallOptions
2021-05-14 22:31:36 +00:00
| InstallStack InstallOptions
2020-05-10 22:18:53 +00:00
2020-01-11 20:15:05 +00:00
data InstallOptions = InstallOptions
2020-03-17 21:43:00 +00:00
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
2020-09-19 09:52:12 +00:00
, instBindist :: Maybe URI
2020-10-25 09:54:04 +00:00
, instSet :: Bool
2020-01-11 20:15:05 +00:00
}
2020-05-10 22:18:53 +00:00
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
2020-09-20 15:57:16 +00:00
| SetHLS SetOptions
2021-05-14 22:31:36 +00:00
| SetStack SetOptions
2020-05-10 22:18:53 +00:00
2021-02-25 17:21:25 +00:00
-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
| SetToolTag Tag
| SetRecommended
| SetNext
2020-05-10 22:18:53 +00:00
data SetOptions = SetOptions
2021-02-25 17:21:25 +00:00
{ sToolVer :: SetToolVersion
2020-01-11 20:15:05 +00:00
}
data ListOptions = ListOptions
2021-04-01 15:21:00 +00:00
{ loTool :: Maybe Tool
2020-04-22 10:30:02 +00:00
, lCriteria :: Maybe ListCriteria
, lRawFormat :: Bool
2020-01-11 20:15:05 +00:00
}
2020-05-10 22:18:53 +00:00
data RmCommand = RmGHC RmOptions
| RmCabal Version
2020-09-20 15:57:16 +00:00
| RmHLS Version
2021-05-14 22:31:36 +00:00
| RmStack Version
2020-05-10 22:18:53 +00:00
2020-01-11 20:15:05 +00:00
data RmOptions = RmOptions
2020-04-25 10:06:41 +00:00
{ ghcVer :: GHCTargetVersion
2020-01-11 20:15:05 +00:00
}
2020-04-25 10:06:41 +00:00
data CompileCommand = CompileGHC GHCCompileOptions
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
data GHCCompileOptions = GHCCompileOptions
2021-04-28 16:45:48 +00:00
{ targetGhc :: Either Version GitBranch
2021-05-14 21:09:45 +00:00
, bootstrapGhc :: Either Version FilePath
2020-04-25 10:06:41 +00:00
, jobs :: Maybe Int
2021-05-14 21:09:45 +00:00
, buildConfig :: Maybe FilePath
, patchDir :: Maybe FilePath
2020-04-25 10:06:41 +00:00
, crossTarget :: Maybe Text
, addConfArgs :: [ Text ]
2020-10-25 09:54:04 +00:00
, setCompile :: Bool
2021-06-05 20:26:35 +00:00
, ovewrwiteVer :: Maybe Version
2021-07-20 11:08:17 +00:00
, buildFlavour :: Maybe String
2021-07-20 19:45:24 +00:00
, hadrian :: Bool
2020-04-25 10:06:41 +00:00
}
2020-01-11 20:15:05 +00:00
data UpgradeOpts = UpgradeInplace
2021-05-14 21:09:45 +00:00
| UpgradeAt FilePath
2020-01-11 20:15:05 +00:00
| UpgradeGHCupDir
deriving Show
2020-04-18 13:05:05 +00:00
data ChangeLogOptions = ChangeLogOptions
{ clOpen :: Bool
, clTool :: Maybe Tool
, clToolVer :: Maybe ToolVersion
}
2020-01-11 20:15:05 +00:00
2021-07-12 13:40:42 +00:00
data WhereisCommand = WhereisTool Tool ( Maybe ToolVersion )
data WhereisOptions = WhereisOptions {
directory :: Bool
}
2021-07-19 14:49:18 +00:00
data PrefetchOptions = PrefetchOptions {
pfCacheDir :: Maybe FilePath
}
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions ( Maybe ToolVersion )
| PrefetchCabal PrefetchOptions ( Maybe ToolVersion )
| PrefetchHLS PrefetchOptions ( Maybe ToolVersion )
| PrefetchStack PrefetchOptions ( Maybe ToolVersion )
| PrefetchMetadata
data PrefetchGHCOptions = PrefetchGHCOptions {
pfGHCSrc :: Bool
, pfGHCCacheDir :: Maybe FilePath
}
2021-07-12 13:40:42 +00:00
2020-10-24 20:03:00 +00:00
-- 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")
2021-02-24 13:18:11 +00:00
--
-- This example makes --recursive enabled by default, so
2020-10-24 20:03:00 +00:00
-- the help is shown only for --no-recursive.
2021-02-24 13:18:11 +00:00
invertableSwitch
2020-10-24 20:03:00 +00:00
:: 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
2021-06-18 09:31:32 +00:00
( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt )
2020-10-24 20:03:00 +00:00
<|> flag' False ( dismod <> long nolongopt <> if defv then short shortopt else mempty )
)
where
nolongopt = " no- " ++ longopt
2020-01-11 20:15:05 +00:00
opts :: Parser Options
opts =
Options
2020-10-24 20:03:00 +00:00
<$> invertableSwitch " verbose " 'v' False ( help " Enable verbosity (default: disabled) " )
<*> invertableSwitch " cache " 'c' False ( help " Cache downloads in ~/.ghcup/cache (default: disabled) " )
2020-01-11 20:15:05 +00:00
<*> ( optional
( option
( eitherReader parseUri )
2020-03-09 21:21:22 +00:00
( short 's'
<> long " url-source "
<> metavar " URL "
<> help " Alternative ghcup download info url "
<> internal
2020-01-11 20:15:05 +00:00
)
)
)
2020-10-24 20:03:00 +00:00
<*> ( fmap . fmap ) not ( invertableSwitch " verify " 'n' True ( help " Disable tarball checksum verification (default: enabled) " ) )
<*> optional ( option
2020-04-22 16:12:40 +00:00
( eitherReader keepOnParser )
( long " keep "
<> metavar " <always|errors|never> "
<> help
2020-09-12 14:41:17 +00:00
" Keep build directories? (default: errors) "
2020-04-29 17:12:58 +00:00
<> hidden
2020-10-24 20:03:00 +00:00
) )
<*> optional ( option
2020-04-29 17:12:58 +00:00
( 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
2020-10-24 20:03:00 +00:00
) )
2021-07-18 21:29:09 +00:00
<*> invertableSwitch " offline " 'o' False ( help " Don't do any network calls, trying cached assets and failing if missing. " )
2020-01-11 20:15:05 +00:00
<*> com
where
parseUri s' =
2021-03-11 16:03:51 +00:00
first show $ parseURI strictURIParserOptions ( UTF8 . fromString s' )
2020-01-11 20:15:05 +00:00
com :: Parser Command
com =
subparser
2020-07-06 20:39:16 +00:00
# if defined ( BRICK )
2020-01-11 20:15:05 +00:00
( command
2020-07-06 20:39:16 +00:00
" tui "
( ( \ _ -> Interactive )
<$> ( info
helper
( progDesc " Start the interactive GHCup UI "
)
)
)
<> command
# else
( command
# endif
2020-01-11 20:15:05 +00:00
" install "
2020-05-10 22:18:53 +00:00
( Install
2021-03-11 16:03:51 +00:00
<$> info
2020-05-10 22:18:53 +00:00
( installParser <**> helper )
2021-06-06 09:59:51 +00:00
( progDesc " Install or update GHC/cabal/HLS "
2020-05-10 22:18:53 +00:00
<> footerDoc ( Just $ text installToolFooter )
)
2020-01-11 20:15:05 +00:00
)
2020-04-12 10:11:24 +00:00
<> command
" set "
2021-03-11 16:03:51 +00:00
( info
( Set <$> setParser <**> helper )
( progDesc " Set currently active GHC/cabal version "
<> footerDoc ( Just $ text setFooter )
)
2020-04-12 10:11:24 +00:00
)
<> command
" rm "
2021-03-11 16:03:51 +00:00
( info
( Rm <$> rmParser <**> helper )
2021-06-06 09:59:51 +00:00
( progDesc " Remove a GHC/cabal/HLS version "
2021-03-11 16:03:51 +00:00
<> footerDoc ( Just $ text rmFooter )
)
2020-04-12 10:11:24 +00:00
)
2020-05-10 22:18:53 +00:00
2020-01-11 20:15:05 +00:00
<> command
" list "
2021-03-11 16:03:51 +00:00
( info ( List <$> listOpts <**> helper )
( progDesc " Show available GHCs and other tools " )
2020-01-11 20:15:05 +00:00
)
<> command
" upgrade "
2020-04-18 13:05:05 +00:00
( info
( ( Upgrade <$> upgradeOptsP <*> switch
( short 'f' <> long " force " <> help " Force update " )
)
<**> helper
)
( progDesc " Upgrade ghcup " )
)
2020-03-09 21:21:22 +00:00
<> command
" compile "
( Compile
2021-03-11 16:03:51 +00:00
<$> info ( compileP <**> helper )
( progDesc " Compile a tool from source " )
2020-03-09 21:21:22 +00:00
)
2021-07-12 13:40:42 +00:00
<> 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 ) )
)
2021-07-19 14:49:18 +00:00
<> command
" prefetch "
( info
( ( Prefetch
<$> prefetchP
) <**> helper
)
( progDesc " Prefetch assets "
<> footerDoc ( Just $ text prefetchFooter ) )
)
2020-01-11 20:15:05 +00:00
<> commandGroup " Main commands: "
)
<|> subparser
( command
" debug-info "
2021-03-11 16:03:51 +00:00
( ( \ _ -> DInfo ) <$> info helper ( progDesc " Show debug info " ) )
2020-04-10 15:36:27 +00:00
<> command
" tool-requirements "
( ( \ _ -> ToolRequirements )
2021-03-11 16:03:51 +00:00
<$> info helper
( progDesc " Show the requirements for ghc/cabal " )
2020-04-10 15:36:27 +00:00
)
2020-04-18 13:05:05 +00:00
<> command
" changelog "
2021-03-11 16:03:51 +00:00
( info
2020-05-10 22:18:53 +00:00
( fmap ChangeLog changelogP <**> helper )
( progDesc " Find/show changelog "
<> footerDoc ( Just $ text changeLogFooter )
)
2020-04-18 13:05:05 +00:00
)
2020-01-11 20:15:05 +00:00
<> commandGroup " Other commands: "
<> hidden
)
2020-05-10 22:18:53 +00:00
<|> subparser
( command
" install-cabal "
2021-03-11 16:03:51 +00:00
( info
2021-02-24 13:18:11 +00:00
( ( InstallCabalLegacy <$> installOpts ( Just Cabal ) ) <**> helper )
2020-05-10 22:18:53 +00:00
( progDesc " Install or update cabal "
<> footerDoc ( Just $ text installCabalFooter )
)
)
<> internal
)
2021-06-18 09:31:32 +00:00
<|> subparser
( command
" nuke "
( info ( pure Nuke <**> helper )
( progDesc " Completely remove ghcup from your system " ) )
<> commandGroup " Nuclear Commands: "
)
2020-04-17 20:11:41 +00:00
where
2020-05-10 22:18:53 +00:00
installToolFooter :: String
2020-07-04 19:49:59 +00:00
installToolFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
Installs GHC or cabal . When no command is given , installs GHC
with the specified version / tag .
2020-10-25 09:54:57 +00:00
It is recommended to always specify a subcommand ( ghc / cabal / hls ) .| ]
2020-05-10 22:18:53 +00:00
setFooter :: String
2020-07-04 19:49:59 +00:00
setFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
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 ) .
2020-10-25 09:54:57 +00:00
It is recommended to always specify a subcommand ( ghc / cabal / hls ) .| ]
2020-05-10 22:18:53 +00:00
rmFooter :: String
2020-07-04 19:49:59 +00:00
rmFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
Remove the given GHC or cabal version . When no command is given ,
defaults to removing GHC with the specified version .
2020-10-25 09:54:57 +00:00
It is recommended to always specify a subcommand ( ghc / cabal / hls ) .| ]
2020-05-10 22:18:53 +00:00
changeLogFooter :: String
2020-07-04 19:49:59 +00:00
changeLogFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
By default returns the URI of the ChangeLog of the latest GHC release .
Pass '- o' to automatically open via xdg - open .| ]
2021-07-12 13:40:42 +00:00
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|]
2021-07-19 14:49:18 +00:00
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|]
2021-07-12 13:40:42 +00:00
2020-05-10 22:18:53 +00:00
installCabalFooter :: String
2020-07-04 19:49:59 +00:00
installCabalFooter = [ s | Discussion :
2020-04-17 20:11:41 +00:00
Installs the specified cabal - install version ( or a recommended default one )
into " ~/.ghcup/bin " , so it can be overwritten by later
" cabal install cabal-install " , which installs into " ~/.cabal/bin " by
default . Make sure to set up your PATH appropriately , so the cabal
installation takes precedence .| ]
2020-05-10 22:18:53 +00:00
installParser :: Parser ( Either InstallCommand InstallOptions )
installParser =
( Left <$> subparser
( command
" ghc "
( InstallGHC
2021-03-11 16:03:51 +00:00
<$> info
2021-02-24 13:18:11 +00:00
( installOpts ( Just GHC ) <**> helper )
2020-05-10 22:18:53 +00:00
( progDesc " Install GHC "
<> footerDoc ( Just $ text installGHCFooter )
)
)
<> command
" cabal "
( InstallCabal
2021-03-11 16:03:51 +00:00
<$> info
2021-02-24 13:18:11 +00:00
( installOpts ( Just Cabal ) <**> helper )
2020-05-10 22:18:53 +00:00
( progDesc " Install Cabal "
<> footerDoc ( Just $ text installCabalFooter )
)
)
2020-09-20 15:57:16 +00:00
<> command
" hls "
( InstallHLS
2021-03-11 16:03:51 +00:00
<$> info
2021-02-24 13:18:11 +00:00
( installOpts ( Just HLS ) <**> helper )
2020-09-20 15:57:16 +00:00
( progDesc " Install haskell-languge-server "
<> footerDoc ( Just $ text installHLSFooter )
)
)
2021-05-14 22:31:36 +00:00
<> command
" stack "
( InstallStack
<$> info
( installOpts ( Just Stack ) <**> helper )
( progDesc " Install stack "
<> footerDoc ( Just $ text installStackFooter )
)
)
2020-05-10 22:18:53 +00:00
)
)
2021-02-24 13:18:11 +00:00
<|> ( Right <$> installOpts Nothing )
2020-05-10 22:18:53 +00:00
where
2020-09-20 15:57:16 +00:00
installHLSFooter :: String
installHLSFooter = [ s | Discussion :
Installs haskell - language - server binaries and wrapper
into " ~/.ghcup/bin "
Examples :
2021-05-14 22:31:36 +00:00
# install recommended HLS
2020-09-20 15:57:16 +00:00
ghcup install hls | ]
2021-05-14 22:31:36 +00:00
installStackFooter :: String
installStackFooter = [ s | Discussion :
Installs stack binaries into " ~/.ghcup/bin "
Examples :
# install recommended Stack
ghcup install stack | ]
2020-05-10 22:18:53 +00:00
installGHCFooter :: String
2020-07-04 19:49:59 +00:00
installGHCFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
Installs the specified GHC version ( or a recommended default one ) into
a self - contained " ~/.ghcup/ghc/<ghcver> " directory
2020-08-06 11:28:20 +00:00
and symlinks the ghc binaries to " ~/.ghcup/bin/<binary>-<ghcver> " .
Examples :
2020-09-19 09:52:12 +00:00
# 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 | ]
2020-01-11 20:15:05 +00:00
2021-02-24 13:18:11 +00:00
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
2020-10-25 09:54:04 +00:00
( \ p ( u , v ) b -> InstallOptions v p u b )
2021-03-11 16:03:51 +00:00
<$> optional
2020-03-17 21:43:00 +00:00
( option
( eitherReader platformParser )
( short 'p'
<> long " platform "
<> metavar " PLATFORM "
<> help
" Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux "
)
)
2020-09-19 09:52:12 +00:00
<*> ( ( ( , )
2021-03-11 16:03:51 +00:00
<$> optional
2020-09-19 09:52:12 +00:00
( option
( eitherReader bindistParser )
( short 'u' <> long " url " <> metavar " BINDIST_URL " <> help
" Install the specified version from this bindist "
)
)
2021-02-25 14:46:08 +00:00
<*> ( Just <$> toolVersionArgument Nothing tool )
2020-07-21 18:18:51 +00:00
)
2021-03-11 16:03:51 +00:00
<|> pure ( Nothing , Nothing )
2020-07-21 18:18:51 +00:00
)
2020-10-25 09:54:04 +00:00
<*> flag
False
True
( long " set " <> help
" Set as active version after install "
)
2020-03-17 21:43:00 +00:00
2020-01-11 20:15:05 +00:00
2020-05-10 22:18:53 +00:00
setParser :: Parser ( Either SetCommand SetOptions )
setParser =
( Left <$> subparser
( command
" ghc "
( SetGHC
2021-03-11 16:03:51 +00:00
<$> info
2021-02-24 13:18:11 +00:00
( setOpts ( Just GHC ) <**> helper )
2020-05-10 22:18:53 +00:00
( progDesc " Set GHC version "
<> footerDoc ( Just $ text setGHCFooter )
)
)
<> command
" cabal "
( SetCabal
2021-03-11 16:03:51 +00:00
<$> info
2021-02-24 13:18:11 +00:00
( setOpts ( Just Cabal ) <**> helper )
2020-05-10 22:18:53 +00:00
( progDesc " Set Cabal version "
<> footerDoc ( Just $ text setCabalFooter )
)
)
2020-09-20 15:57:16 +00:00
<> command
" hls "
( SetHLS
2021-03-11 16:03:51 +00:00
<$> info
2021-02-24 13:18:11 +00:00
( setOpts ( Just HLS ) <**> helper )
2020-09-20 15:57:16 +00:00
( progDesc " Set haskell-language-server version "
<> footerDoc ( Just $ text setHLSFooter )
)
)
2021-05-14 22:31:36 +00:00
<> command
" stack "
( SetStack
<$> info
( setOpts ( Just Stack ) <**> helper )
( progDesc " Set stack version "
<> footerDoc ( Just $ text setStackFooter )
)
)
2020-05-10 22:18:53 +00:00
)
)
2021-02-24 13:18:11 +00:00
<|> ( Right <$> setOpts Nothing )
2020-05-10 22:18:53 +00:00
where
setGHCFooter :: String
2020-07-04 19:49:59 +00:00
setGHCFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
Sets the the current GHC version by creating non - versioned
symlinks for all ghc binaries of the specified version in
" ~/.ghcup/bin/<binary> " .| ]
setCabalFooter :: String
2020-07-04 19:49:59 +00:00
setCabalFooter = [ s | Discussion :
2020-05-10 22:18:53 +00:00
Sets the the current Cabal version .| ]
2021-05-14 22:31:36 +00:00
setStackFooter :: String
setStackFooter = [ s | Discussion :
Sets the the current Stack version .| ]
2020-09-20 15:57:16 +00:00
setHLSFooter :: String
setHLSFooter = [ s | Discussion :
Sets the the current haskell - language - server version .| ]
2020-05-10 22:18:53 +00:00
2021-02-24 13:18:11 +00:00
setOpts :: Maybe Tool -> Parser SetOptions
2021-02-25 17:21:25 +00:00
setOpts tool = SetOptions <$>
( fromMaybe SetRecommended <$>
optional ( setVersionArgument ( Just ListInstalled ) tool ) )
2020-01-11 20:15:05 +00:00
listOpts :: Parser ListOptions
listOpts =
ListOptions
<$> optional
( option
( eitherReader toolParser )
( short 't' <> long " tool " <> metavar " <ghc|cabal> " <> help
" Tool to list versions for. Default is all "
)
)
2021-03-11 16:03:51 +00:00
<*> optional
2020-01-11 20:15:05 +00:00
( option
( eitherReader criteriaParser )
( short 'c'
<> long " show-criteria "
<> metavar " <installed|set> "
<> help " Show only installed or set tool versions "
)
)
2020-04-22 10:30:02 +00:00
<*> switch
( short 'r' <> long " raw-format " <> help " More machine-parsable format "
)
2020-01-11 20:15:05 +00:00
2020-05-10 22:18:53 +00:00
rmParser :: Parser ( Either RmCommand RmOptions )
rmParser =
( Left <$> subparser
( command
" ghc "
2021-03-11 16:03:51 +00:00
( RmGHC <$> info ( rmOpts ( Just GHC ) <**> helper ) ( progDesc " Remove GHC version " ) )
2020-05-10 22:18:53 +00:00
<> command
" cabal "
( RmCabal
2021-03-11 16:03:51 +00:00
<$> info ( versionParser' ( Just ListInstalled ) ( Just Cabal ) <**> helper )
( progDesc " Remove Cabal version " )
2020-05-10 22:18:53 +00:00
)
2020-09-20 15:57:16 +00:00
<> command
" hls "
( RmHLS
2021-03-11 16:03:51 +00:00
<$> info ( versionParser' ( Just ListInstalled ) ( Just HLS ) <**> helper )
( progDesc " Remove haskell-language-server version " )
2020-09-20 15:57:16 +00:00
)
2021-05-14 22:31:36 +00:00
<> command
" stack "
( RmStack
<$> info ( versionParser' ( Just ListInstalled ) ( Just Stack ) <**> helper )
( progDesc " Remove stack version " )
)
2020-05-10 22:18:53 +00:00
)
)
2021-02-24 13:18:11 +00:00
<|> ( Right <$> rmOpts Nothing )
2020-05-10 22:18:53 +00:00
2021-02-24 13:18:11 +00:00
rmOpts :: Maybe Tool -> Parser RmOptions
2021-02-25 14:46:08 +00:00
rmOpts tool = RmOptions <$> versionArgument ( Just ListInstalled ) tool
2020-01-11 20:15:05 +00:00
2020-04-18 13:05:05 +00:00
changelogP :: Parser ChangeLogOptions
changelogP =
( \ x y -> ChangeLogOptions x y )
<$> switch ( short 'o' <> long " open " <> help " xdg-open the changelog url " )
2021-03-11 16:03:51 +00:00
<*> optional
2020-04-18 13:05:05 +00:00
( option
( eitherReader
( \ s' -> case fmap toLower s' of
" ghc " -> Right GHC
" cabal " -> Right Cabal
" ghcup " -> Right GHCup
2021-05-14 22:31:36 +00:00
" stack " -> Right Stack
2021-03-11 16:03:51 +00:00
e -> Left e
2020-04-18 13:05:05 +00:00
)
)
( short 't' <> long " tool " <> metavar " <ghc|cabal|ghcup> " <> help
" Open changelog for given tool (default: ghc) "
)
)
2021-02-25 14:46:08 +00:00
<*> optional ( toolVersionArgument Nothing Nothing )
2020-04-18 13:05:05 +00:00
2020-01-11 20:15:05 +00:00
compileP :: Parser CompileCommand
compileP = subparser
( command
" ghc "
( CompileGHC
2021-03-11 16:03:51 +00:00
<$> info
2020-04-25 10:06:41 +00:00
( ghcCompileOpts <**> helper )
2020-04-18 13:05:05 +00:00
( progDesc " Compile GHC from source "
<> footerDoc ( Just $ text compileFooter )
)
2020-01-11 20:15:05 +00:00
)
)
2020-04-17 20:11:41 +00:00
where
2020-07-04 19:49:59 +00:00
compileFooter = [ s | Discussion :
2020-04-17 20:11:41 +00:00
Compiles and installs the specified GHC version into
a self - contained " ~/.ghcup/ghc/<ghcver> " directory
and symlinks the ghc binaries to " ~/.ghcup/bin/<binary>-<ghcver> " .
2020-04-25 10:06:41 +00:00
This also allows building a cross - compiler . Consult the documentation
first : < https :// gitlab . haskell . org / ghc / ghc /-/ wikis / building / cross - compiling # configuring - the - build >
ENV variables :
Various toolchain variables will be passed onto the ghc build system ,
such as : CC , LD , OBJDUMP , NM , AR , RANLIB .
2020-04-17 20:11:41 +00:00
Examples :
2021-04-28 16:45:48 +00:00
# compile from known version
2020-04-17 20:11:41 +00:00
ghcup compile ghc - j 4 - v 8.4 . 2 - b 8.2 . 2
2021-04-28 16:45:48 +00:00
# compile from git commit / reference
ghcup compile ghc - j 4 - g master - b 8.2 . 2
2020-04-25 10:06:41 +00:00
# specify path to bootstrap ghc
ghcup compile ghc - j 4 - v 8.4 . 2 - b / usr / bin / ghc - 8.2 . 2
# build cross compiler
ghcup compile ghc - j 4 - v 8.4 . 2 - b 8.2 . 2 - x armv7 - unknown - linux - gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
2020-04-17 20:11:41 +00:00
2020-01-11 20:15:05 +00:00
2021-07-12 13:40:42 +00:00
whereisP :: Parser WhereisCommand
whereisP = subparser
( 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 " ) )
)
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|]
2021-07-19 14:49:18 +00:00
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 " )
)
)
2020-04-25 10:06:41 +00:00
ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts =
2021-04-28 16:45:48 +00:00
GHCCompileOptions
<$> ( ( Left <$> option
2020-01-11 20:15:05 +00:00
( eitherReader
2021-03-11 16:03:51 +00:00
( first ( const " Not a valid version " ) . version . T . pack )
2020-01-11 20:15:05 +00:00
)
( short 'v' <> long " version " <> metavar " VERSION " <> help
" The tool version to compile "
)
2021-04-28 16:45:48 +00:00
) <|>
( 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) " ) )
) ) )
2021-03-11 16:03:51 +00:00
<*> option
2020-01-11 20:15:05 +00:00
( eitherReader
2020-04-08 20:17:39 +00:00
( \ x ->
2021-05-14 21:09:45 +00:00
( 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 " )
2020-04-08 20:17:39 +00:00
)
2020-01-11 20:15:05 +00:00
)
( short 'b'
2020-04-08 20:17:39 +00:00
<> long " bootstrap-ghc "
<> metavar " BOOTSTRAP_GHC "
<> help
" The GHC version (or full path) to bootstrap with (must be installed) "
2020-01-11 20:15:05 +00:00
)
<*> optional
( option
( eitherReader ( readEither @ Int ) )
( short 'j' <> long " jobs " <> metavar " JOBS " <> help
" How many jobs to use for make "
)
)
<*> optional
( option
2021-05-14 21:09:45 +00:00
str
2020-01-11 20:15:05 +00:00
( short 'c' <> long " config " <> metavar " CONFIG " <> help
" Absolute path to build config file "
)
)
2020-04-08 20:57:57 +00:00
<*> optional
( option
2021-05-14 21:09:45 +00:00
str
2020-04-08 20:57:57 +00:00
( short 'p' <> long " patchdir " <> metavar " PATCH_DIR " <> help
" Absolute path to patch directory (applied in order, uses -p1) "
)
)
2021-04-28 16:45:48 +00:00
<*> 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 "
)
2021-06-05 20:26:35 +00:00
<*> 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' "
)
)
2021-07-20 11:08:17 +00:00
<*> 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') "
)
)
2021-07-20 19:45:24 +00:00
<*> switch
( long " hadrian " <> help " Use the hadrian build system instead of make (only git versions seem to be properly supported atm) "
)
2020-01-11 20:15:05 +00:00
toolVersionParser :: Parser ToolVersion
2020-11-20 17:37:48 +00:00
toolVersionParser = verP' <|> toolP
2020-01-11 20:15:05 +00:00
where
2020-11-20 17:37:48 +00:00
verP' = ToolVersion <$> versionParser
2020-01-11 20:15:05 +00:00
toolP =
ToolTag
2021-03-11 16:03:51 +00:00
<$> option
2020-04-12 10:11:24 +00:00
( eitherReader tagEither )
2020-01-11 20:15:05 +00:00
( short 't' <> long " tag " <> metavar " TAG " <> help " The target tag " )
2020-04-12 10:11:24 +00:00
-- | same as toolVersionParser, except as an argument.
2021-02-25 14:46:08 +00:00
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument criteria tool =
2021-02-25 15:13:00 +00:00
argument ( eitherReader toolVersionEither )
( metavar " VERSION|TAG "
2021-02-25 17:21:25 +00:00
<> completer ( tagCompleter ( fromMaybe GHC tool ) [] )
<> foldMap ( completer . versionCompleter criteria ) tool )
setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
setVersionArgument criteria tool =
argument ( eitherReader setEither )
( metavar " VERSION|TAG|next "
<> completer ( tagCompleter ( fromMaybe GHC tool ) [ " next " ] )
2021-02-25 15:13:00 +00:00
<> foldMap ( completer . versionCompleter criteria ) tool )
2021-02-25 17:21:25 +00:00
where
setEither s' =
parseSet s'
2021-03-11 16:03:51 +00:00
<|> second SetToolTag ( tagEither s' )
<|> second SetToolVersion ( tVersionEither s' )
2021-02-25 17:21:25 +00:00
parseSet s' = case fmap toLower s' of
" next " -> Right SetNext
other -> Left [ i | Unknown tag / version # { other } | ]
2021-02-24 13:18:11 +00:00
2021-02-25 14:46:08 +00:00
versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
versionArgument criteria tool = argument ( eitherReader tVersionEither ) ( metavar " VERSION " <> foldMap ( completer . versionCompleter criteria ) tool )
2021-02-24 13:18:11 +00:00
2021-02-25 17:21:25 +00:00
tagCompleter :: Tool -> [ String ] -> Completer
tagCompleter tool add = listIOCompleter $ do
2021-07-18 12:39:49 +00:00
dirs' <- liftIO getAllDirs
2021-07-18 21:29:09 +00:00
let appState = LeanAppState
( Settings True False Never Curl False GHCupURL True )
dirs'
defaultKeyBindings
2021-02-25 15:13:00 +00:00
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
2021-05-14 21:09:45 +00:00
let runLogger = myLoggerT loggerConfig
2021-07-18 21:29:09 +00:00
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
2021-02-25 15:13:00 +00:00
case mGhcUpInfo of
2021-05-14 21:09:45 +00:00
VRight ghcupInfo -> do
2021-02-25 15:13:00 +00:00
let allTags = filter ( \ t -> t /= Old )
$ join
2021-07-27 20:13:22 +00:00
$ fmap _viTags
2021-02-25 15:13:00 +00:00
$ M . elems
2021-05-14 21:09:45 +00:00
$ availableToolVersions ( _ghcupDownloads ghcupInfo ) tool
2021-03-01 23:15:03 +00:00
pure $ nub $ ( add ++ ) $ fmap tagToString allTags
2021-02-25 17:21:25 +00:00
VLeft _ -> pure ( nub $ [ " recommended " , " latest " ] ++ add )
2021-02-24 13:18:11 +00:00
2021-02-25 14:46:08 +00:00
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
2021-02-25 14:49:04 +00:00
versionCompleter criteria tool = listIOCompleter $ do
2021-07-18 12:39:49 +00:00
dirs' <- liftIO getAllDirs
2021-02-25 14:49:04 +00:00
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
2021-05-14 21:09:45 +00:00
let runLogger = myLoggerT loggerConfig
2021-07-18 21:29:09 +00:00
settings = Settings True False Never Curl False GHCupURL True
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \ pfreq -> do
2021-05-14 21:09:45 +00:00
forFold mGhcUpInfo $ \ ghcupInfo -> do
let appState = AppState
2021-07-18 21:29:09 +00:00
settings
2021-05-14 21:09:45 +00:00
dirs'
defaultKeyBindings
ghcupInfo
pfreq
runEnv = runLogger . flip runReaderT appState
installedVersions <- runEnv $ listVersions ( Just tool ) criteria
2021-02-25 14:49:04 +00:00
return $ T . unpack . prettyVer . lVer <$> installedVersions
2020-04-12 10:11:24 +00:00
2020-04-25 10:06:41 +00:00
versionParser :: Parser GHCTargetVersion
2020-04-12 10:11:24 +00:00
versionParser = option
2020-04-25 10:06:41 +00:00
( eitherReader tVersionEither )
2020-04-12 10:11:24 +00:00
( short 'v' <> long " version " <> metavar " VERSION " <> help " The target version "
)
2021-02-25 14:46:08 +00:00
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument
2021-02-24 23:07:38 +00:00
( eitherReader ( first show . version . T . pack ) )
2021-02-25 14:46:08 +00:00
( metavar " VERSION " <> foldMap ( completer . versionCompleter criteria ) tool )
2020-05-10 22:18:53 +00:00
2020-04-12 10:11:24 +00:00
tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of
" recommended " -> Right Recommended
" latest " -> Right Latest
2020-04-22 00:33:35 +00:00
( 'b' : 'a' : 's' : 'e' : '-' : ver' ) -> case pvp ( T . pack ver' ) of
Right x -> Right ( Base x )
Left _ -> Left [ i | Invalid PVP version for base # { ver' } | ]
2021-02-24 23:07:38 +00:00
other -> Left [ i | Unknown tag # { other } | ]
2020-04-12 10:11:24 +00:00
2020-04-25 10:06:41 +00:00
tVersionEither :: String -> Either String GHCTargetVersion
tVersionEither =
2021-03-11 16:03:51 +00:00
first ( const " Not a valid version " ) . MP . parse ghcTargetVerP " " . T . pack
2020-04-25 10:06:41 +00:00
2020-04-12 10:11:24 +00:00
toolVersionEither :: String -> Either String ToolVersion
toolVersionEither s' =
2021-03-11 16:03:51 +00:00
second ToolTag ( tagEither s' ) <|> second ToolVersion ( tVersionEither s' )
2020-04-12 10:11:24 +00:00
2020-01-11 20:15:05 +00:00
toolParser :: String -> Either String Tool
toolParser s' | t == T . pack " ghc " = Right GHC
| t == T . pack " cabal " = Right Cabal
| otherwise = Left ( " Unknown tool: " <> s' )
where t = T . toLower ( T . pack s' )
criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T . pack " installed " = Right ListInstalled
| t == T . pack " set " = Right ListSet
| otherwise = Left ( " Unknown criteria: " <> s' )
where t = T . toLower ( T . pack s' )
2020-04-22 16:12:40 +00:00
keepOnParser :: String -> Either String KeepDirs
keepOnParser s' | t == T . pack " always " = Right Always
| t == T . pack " errors " = Right Errors
| t == T . pack " never " = Right Never
| otherwise = Left ( " Unknown keep value: " <> s' )
where t = T . toLower ( T . pack s' )
2020-04-29 17:12:58 +00:00
downloaderParser :: String -> Either String Downloader
downloaderParser s' | t == T . pack " curl " = Right Curl
| t == T . pack " wget " = Right Wget
# if defined ( INTERNAL_DOWNLOADER )
| t == T . pack " internal " = Right Internal
# endif
| otherwise = Left ( " Unknown downloader value: " <> s' )
where t = T . toLower ( T . pack s' )
2020-03-17 00:58:59 +00:00
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP . parse ( platformP <* MP . eof ) " " ( T . pack s' ) of
Right r -> pure r
Left e -> Left $ errorBundlePretty e
where
archP :: MP . Parsec Void Text Architecture
2021-03-11 16:03:51 +00:00
archP = MP . try ( MP . chunk " x86_64 " $> A_64 ) <|> ( MP . chunk " i386 " $> A_32 )
2020-03-17 00:58:59 +00:00
platformP :: MP . Parsec Void Text PlatformRequest
platformP = choice'
[ ( \ a mv -> PlatformRequest a FreeBSD mv )
2020-03-21 21:19:37 +00:00
<$> ( archP <* MP . chunk " - " )
<*> ( MP . chunk " portbld "
*> ( MP . try ( Just <$> verP ( MP . chunk " -freebsd " <* MP . eof ) )
2020-03-17 00:58:59 +00:00
<|> pure Nothing
)
2020-03-21 21:19:37 +00:00
<* MP . chunk " -freebsd "
2020-03-17 00:58:59 +00:00
)
, ( \ a mv -> PlatformRequest a Darwin mv )
2020-03-21 21:19:37 +00:00
<$> ( archP <* MP . chunk " - " )
<*> ( MP . chunk " apple "
*> ( MP . try ( Just <$> verP ( MP . chunk " -darwin " <* MP . eof ) )
2020-03-17 00:58:59 +00:00
<|> pure Nothing
)
2020-03-21 21:19:37 +00:00
<* MP . chunk " -darwin "
2020-03-17 00:58:59 +00:00
)
, ( \ a d mv -> PlatformRequest a ( Linux d ) mv )
2020-03-21 21:19:37 +00:00
<$> ( archP <* MP . chunk " - " )
2020-03-17 00:58:59 +00:00
<*> distroP
2020-03-21 21:19:37 +00:00
<*> ( ( MP . try ( Just <$> verP ( MP . chunk " -linux " <* MP . eof ) ) <|> pure Nothing
)
<* MP . chunk " -linux "
2020-03-17 00:58:59 +00:00
)
]
distroP :: MP . Parsec Void Text LinuxDistro
distroP = choice'
2020-03-21 21:19:37 +00:00
[ MP . chunk " debian " $> Debian
, MP . chunk " deb " $> Debian
, MP . chunk " ubuntu " $> Ubuntu
, MP . chunk " mint " $> Mint
, MP . chunk " fedora " $> Fedora
, MP . chunk " centos " $> CentOS
, MP . chunk " redhat " $> RedHat
, MP . chunk " alpine " $> Alpine
, MP . chunk " gentoo " $> Gentoo
, MP . chunk " exherbo " $> Exherbo
, MP . chunk " unknown " $> UnknownLinux
2020-03-17 00:58:59 +00:00
]
2020-04-25 10:06:41 +00:00
2020-09-19 09:52:12 +00:00
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8 . fromString
2020-03-17 00:58:59 +00:00
2021-05-14 21:09:45 +00:00
toSettings :: Options -> IO ( Settings , KeyBindings )
2020-10-24 20:03:00 +00:00
toSettings options = do
userConf <- runE @ '[ JSONError ] ghcupConfigFile >>= \ case
VRight r -> pure r
VLeft ( V ( JSONDecodeError e ) ) -> do
B . hPut stderr ( " Error decoding config file: " <> ( E . encodeUtf8 . T . pack . show $ e ) )
pure defaultUserSettings
_ -> do
die " Unexpected error! "
2021-05-14 21:09:45 +00:00
pure $ mergeConf options userConf
2020-10-24 20:03:00 +00:00
where
2021-05-14 21:09:45 +00:00
mergeConf :: Options -> UserSettings -> ( Settings , KeyBindings )
mergeConf Options { .. } UserSettings { .. } =
2020-10-25 13:17:17 +00:00
let cache = fromMaybe ( fromMaybe False uCache ) optCache
noVerify = fromMaybe ( fromMaybe False uNoVerify ) optNoVerify
verbose = fromMaybe ( fromMaybe False uVerbose ) optVerbose
keepDirs = fromMaybe ( fromMaybe Errors uKeepDirs ) optKeepDirs
downloader = fromMaybe ( fromMaybe defaultDownloader uDownloader ) optsDownloader
2020-10-24 20:03:00 +00:00
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
2020-10-25 13:17:17 +00:00
urlSource = maybe ( fromMaybe GHCupURL uUrlSource ) OwnSource optUrlSource
2021-07-18 21:29:09 +00:00
noNetwork = fromMaybe ( fromMaybe False uNoNetwork ) optNoNetwork
2021-05-14 21:09:45 +00:00
in ( Settings { .. } , keyBindings )
2020-10-24 20:03:00 +00:00
# if defined ( INTERNAL_DOWNLOADER )
defaultDownloader = Internal
# else
defaultDownloader = Curl
# endif
mergeKeys :: UserKeyBindings -> KeyBindings
mergeKeys UserKeyBindings { .. } =
let KeyBindings { .. } = defaultKeyBindings
in KeyBindings {
bUp = fromMaybe bUp kUp
, bDown = fromMaybe bDown kDown
, bQuit = fromMaybe bQuit kQuit
, bInstall = fromMaybe bInstall kInstall
, bUninstall = fromMaybe bUninstall kUninstall
, bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog
2021-05-14 22:31:36 +00:00
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
2020-10-24 20:03:00 +00:00
}
2020-01-11 20:15:05 +00:00
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
( short 'i' <> long " inplace " <> help
" Upgrade ghcup in-place (wherever it's at) "
)
<|> ( UpgradeAt
2021-03-11 16:03:51 +00:00
<$> option
2021-05-14 21:09:45 +00:00
str
2020-01-11 20:15:05 +00:00
( short 't' <> long " target " <> metavar " TARGET_DIR " <> help
" Absolute filepath to write ghcup into "
)
)
2021-03-11 16:03:51 +00:00
<|> pure UpgradeGHCupDir
2020-01-11 20:15:05 +00:00
2020-04-17 14:56:56 +00:00
describe_result :: String
2021-03-11 16:03:51 +00:00
describe_result = $ ( LitE . StringL <$>
2020-04-17 14:56:56 +00:00
runIO ( do
2021-05-14 21:09:45 +00:00
CapturedProcess { .. } <- do
2021-07-18 12:39:49 +00:00
dirs <- liftIO getAllDirs
2021-07-18 21:29:09 +00:00
let settings = AppState ( Settings True False Never Curl False GHCupURL False )
dirs
defaultKeyBindings
2021-05-14 21:09:45 +00:00
flip runReaderT settings $ executeOut " git " [ " describe " ] Nothing
2020-04-17 14:56:56 +00:00
case _exitCode of
2021-05-14 21:09:45 +00:00
ExitSuccess -> pure . T . unpack . decUTF8Safe' $ _stdOut
2020-04-17 14:56:56 +00:00
ExitFailure _ -> pure numericVer
)
)
2020-01-11 20:15:05 +00:00
main :: IO ()
main = do
2021-05-14 21:09:45 +00:00
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
void enableAnsiSupport
2020-04-17 16:54:21 +00:00
let versionHelp = infoOption
( ( " The GHCup Haskell installer, version " <> )
2021-03-11 16:03:51 +00:00
( head . lines $ describe_result )
2020-04-17 16:54:21 +00:00
)
2020-04-17 20:11:41 +00:00
( long " version " <> help " Show version " <> hidden )
2020-04-17 14:56:56 +00:00
let numericVersionHelp = infoOption
numericVer
( long " numeric-version "
<> help " Show the numeric version (for use in scripts) "
2020-04-17 20:11:41 +00:00
<> hidden
2020-04-17 14:56:56 +00:00
)
2020-04-22 18:12:57 +00:00
let listCommands = infoOption
" install set rm install-cabal list upgrade compile debug-info tool-requirements changelog "
( long " list-commands "
<> help " List available commands for shell completion "
<> internal
)
2020-01-11 20:15:05 +00:00
2020-07-04 19:49:59 +00:00
let main_footer = [ s | Discussion :
2020-04-17 20:11:41 +00:00
ghcup installs the Glasgow Haskell Compiler from the official
release channels , enabling you to easily switch between different
2020-04-22 14:14:10 +00:00
versions . It maintains a self - contained ~/. ghcup directory .
ENV variables :
* TMPDIR : where ghcup does the work ( unpacking , building , ... )
* GHCUP_INSTALL_BASE_PREFIX : the base of ghcup ( default : $ HOME )
2020-10-25 09:54:57 +00:00
* GHCUP_USE_XDG_DIRS : set to anything to use XDG style directories
2020-04-17 20:11:41 +00:00
Report bugs at < https :// gitlab . haskell . org / haskell / ghcup - hs / issues >| ]
2020-04-17 14:56:56 +00:00
customExecParser
( prefs showHelpOnError )
2020-04-22 18:12:57 +00:00
( info ( opts <**> helper <**> versionHelp <**> numericVersionHelp <**> listCommands )
2020-04-18 13:05:05 +00:00
( footerDoc ( Just $ text main_footer ) )
)
2020-01-11 20:15:05 +00:00
>>= \ opt @ Options { .. } -> do
2021-07-18 12:39:49 +00:00
dirs @ Dirs { .. } <- getAllDirs
2021-05-14 21:09:45 +00:00
2020-03-17 18:16:21 +00:00
-- create ~/.ghcup dir
2021-06-13 11:41:06 +00:00
ensureDirectories dirs
( settings , keybindings ) <- toSettings opt
2020-03-17 18:16:21 +00:00
2020-01-11 20:15:05 +00:00
-- logger interpreter
2021-07-21 13:43:45 +00:00
logfile <- flip runReaderT dirs $ initGHCupFileLogging
2020-07-06 20:39:16 +00:00
let loggerConfig = LoggerConfig
2020-10-24 20:03:00 +00:00
{ lcPrintDebug = verbose settings
2020-01-11 20:15:05 +00:00
, colorOutter = B . hPut stderr
2021-07-02 21:26:07 +00:00
, rawOutter =
case optCommand of
Nuke -> \ _ -> pure ()
_ -> B . appendFile logfile
2020-01-11 20:15:05 +00:00
}
2020-07-06 20:39:16 +00:00
let runLogger = myLoggerT loggerConfig
2021-05-14 21:09:45 +00:00
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \ _ -> pure () }
2021-07-15 11:32:48 +00:00
-------------------------
-- Setting up appstate --
-------------------------
2021-07-18 12:39:49 +00:00
let leanAppstate = LeanAppState settings dirs keybindings
appState = do
pfreq <- (
runLogger . runE @ '[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \ case
VRight r -> pure r
VLeft e -> do
runLogger
( $ ( logError ) $ T . pack $ prettyShow e )
exitWith ( ExitFailure 2 )
ghcupInfo <-
( runLogger
2021-07-18 21:29:09 +00:00
. flip runReaderT leanAppstate
2021-07-18 12:39:49 +00:00
. runE @ '[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
2021-07-18 21:29:09 +00:00
$ getDownloadsF
2021-07-18 12:39:49 +00:00
)
>>= \ case
VRight r -> pure r
VLeft e -> do
runLogger
( $ ( logError ) $ T . pack $ prettyShow e )
exitWith ( ExitFailure 2 )
let s' = AppState settings dirs keybindings ghcupInfo pfreq
2021-05-14 21:09:45 +00:00
2021-07-22 13:45:08 +00:00
race_ ( liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash )
( threadDelay 5000000 >> runLogger ( $ ( logWarn ) [ i | Killing cleanup thread ( exceeded 5 s timeout ) ... please remove leftover files in # { recycleDir } manually | ] ) )
2021-07-21 13:43:45 +00:00
2021-07-26 16:13:20 +00:00
case optCommand of
Nuke -> pure ()
Whereis _ _ -> pure ()
DInfo -> pure ()
ToolRequirements -> pure ()
ChangeLog _ -> pure ()
# if defined ( BRICK )
Interactive -> pure ()
# endif
_ -> lookupEnv " GHCUP_SKIP_UPDATE_CHECK " >>= \ case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Just _ -> pure ()
2021-07-15 11:32:48 +00:00
2021-07-18 12:39:49 +00:00
-- TODO: always run for windows
( siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools ) >>= \ case
VRight _ -> pure ()
VLeft e -> do
runLogger
( $ ( logError ) $ T . pack $ prettyShow e )
exitWith ( ExitFailure 30 )
pure s'
2021-07-15 11:32:48 +00:00
2021-05-14 21:09:45 +00:00
2021-07-18 21:29:09 +00:00
# if defined ( IS_WINDOWS )
-- FIXME: windows needs 'ensureGlobalTools', which requires
-- full appstate
runLeanAppState = runAppState
# else
2021-07-18 12:39:49 +00:00
runLeanAppState = flip runReaderT leanAppstate
2021-07-18 21:29:09 +00:00
# endif
2021-07-18 12:39:49 +00:00
runAppState action' = do
s' <- liftIO appState
flip runReaderT s' action'
2021-05-14 21:09:45 +00:00
2020-01-11 20:15:05 +00:00
2020-05-10 22:18:53 +00:00
-------------------------
-- Effect interpreters --
-------------------------
2021-07-22 13:45:08 +00:00
2021-05-14 21:09:45 +00:00
let runInstTool' appstate' mInstPlatform =
2020-01-11 20:15:05 +00:00
runLogger
2021-07-18 21:29:09 +00:00
. flip runReaderT ( maybe appstate' ( \ x -> appstate' { pfreq = x } :: AppState ) mInstPlatform )
2020-01-11 20:15:05 +00:00
. runResourceT
. runE
@ ' [ A l r e a d y I n s t a l l e d
, UnknownArchive
2020-07-12 20:29:50 +00:00
# if ! defined ( TAR )
2020-07-04 21:33:48 +00:00
, ArchiveResult
2020-07-12 20:29:50 +00:00
# endif
2020-01-11 20:15:05 +00:00
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
2020-01-11 20:15:05 +00:00
]
2021-07-18 12:39:49 +00:00
let runInstTool mInstPlatform action' = do
s' <- liftIO appState
runInstTool' s' mInstPlatform action'
2020-09-19 09:52:12 +00:00
2020-03-09 21:21:22 +00:00
let
2021-07-18 12:39:49 +00:00
runLeanSetGHC =
runLogger
. runLeanAppState
. runE
@ ' [ F i l e D o e s N o t E x i s t E r r o r
, NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
2020-03-09 21:21:22 +00:00
runSetGHC =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
2020-03-09 21:21:22 +00:00
. runE
@ ' [ F i l e D o e s N o t E x i s t E r r o r
, NotInstalled
, TagNotFound
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
2020-03-09 21:21:22 +00:00
]
2020-01-11 20:15:05 +00:00
2020-05-10 22:18:53 +00:00
let
2021-07-18 12:39:49 +00:00
runLeanSetCabal =
runLogger
. runLeanAppState
. runE
@ ' [ N o t I n s t a l l e d
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
2020-05-10 22:18:53 +00:00
runSetCabal =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
2020-05-10 22:18:53 +00:00
. runE
@ ' [ N o t I n s t a l l e d
, TagNotFound
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
2020-05-10 22:18:53 +00:00
]
2020-09-20 15:57:16 +00:00
let
runSetHLS =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
. runE
@ ' [ N o t I n s t a l l e d
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runLeanSetHLS =
runLogger
. runLeanAppState
2020-09-20 15:57:16 +00:00
. runE
@ ' [ N o t I n s t a l l e d
, TagNotFound
2021-02-25 17:21:25 +00:00
, NextVerNotFound
, NoToolVersionSet
2020-09-20 15:57:16 +00:00
]
2021-07-18 12:39:49 +00:00
let runListGHC = runLogger . runAppState
2020-01-11 20:15:05 +00:00
2020-07-06 20:39:16 +00:00
let runRm =
2021-07-18 12:39:49 +00:00
runLogger . runAppState . runE @ '[NotInstalled]
2020-01-11 20:15:05 +00:00
2021-07-22 13:45:08 +00:00
let runNuke s' =
runLogger . flip runReaderT s' . runE @ '[NotInstalled]
2020-01-11 20:15:05 +00:00
let runDebugInfo =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
2020-01-11 20:15:05 +00:00
. runE
@ '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
2020-01-11 20:15:05 +00:00
. runResourceT
. runE
@ ' [ A l r e a d y I n s t a l l e d
, BuildFailed
, DigestError
2020-04-10 17:27:17 +00:00
, DownloadFailed
2020-01-11 20:15:05 +00:00
, GHCupSetError
, NoDownload
2020-04-10 20:44:43 +00:00
, NotFoundInPATH
2020-04-08 20:57:57 +00:00
, PatchFailed
2020-01-11 20:15:05 +00:00
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
2020-09-17 19:21:16 +00:00
, NotInstalled
2020-07-12 20:29:50 +00:00
# if ! defined ( TAR )
2020-07-04 21:33:48 +00:00
, ArchiveResult
2020-07-12 20:29:50 +00:00
# endif
2020-01-11 20:15:05 +00:00
]
2021-07-12 13:40:42 +00:00
let
2021-07-18 12:39:49 +00:00
runLeanWhereIs =
runLogger
2021-07-19 14:56:28 +00:00
-- 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
2021-07-18 12:39:49 +00:00
. runE
@ ' [ N o t I n s t a l l e d
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
2021-07-12 13:40:42 +00:00
runWhereIs =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
2021-07-12 13:40:42 +00:00
. runE
@ ' [ N o t I n s t a l l e d
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
2020-01-11 20:15:05 +00:00
let runUpgrade =
runLogger
2021-07-18 12:39:49 +00:00
. runAppState
2020-01-11 20:15:05 +00:00
. runResourceT
. runE
@ ' [ D i g e s t E r r o r
, NoDownload
2020-04-15 11:57:44 +00:00
, NoUpdate
2020-01-11 20:15:05 +00:00
, FileDoesNotExistError
, CopyError
2020-03-09 21:21:22 +00:00
, DownloadFailed
2020-01-11 20:15:05 +00:00
]
2021-07-19 14:49:18 +00:00
let runPrefetch =
runLogger
. runAppState
. runResourceT
. runE
@ ' [ T a g N o t F o u n d
, NextVerNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, DownloadFailed
, JSONError
, FileDoesNotExistError
]
2020-05-10 22:18:53 +00:00
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions { .. } =
2020-09-19 09:52:12 +00:00
( case instBindist of
2021-05-14 21:09:45 +00:00
Nothing -> runInstTool instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin ( _tvVersion v )
2020-10-25 09:54:04 +00:00
when instSet $ void $ liftE $ setGHC v SetGHCOnly
2021-02-22 20:55:05 +00:00
pure vi
2021-07-18 12:39:49 +00:00
Just uri -> do
s' <- liftIO appState
runInstTool' s' { settings = settings { noVerify = True } } instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
( DownloadInfo uri ( Just $ RegexDir " ghc-.* " ) " " )
( _tvVersion v )
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
2020-05-10 22:18:53 +00:00
)
>>= \ case
2021-02-22 20:55:05 +00:00
VRight vi -> do
2021-03-11 16:03:51 +00:00
runLogger $ $ ( logInfo ) " GHC installation successful "
forM_ ( _viPostInstall =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
2020-05-10 22:18:53 +00:00
pure ExitSuccess
VLeft ( V ( AlreadyInstalled _ v ) ) -> do
runLogger $ $ ( logWarn )
2021-01-11 07:12:19 +00:00
[ i | GHC ver # { prettyVer v } already installed ; if you really want to reinstall it , you may want to run 'ghcup rm ghc # { prettyVer v } ' f i r s t | ]
2020-05-10 22:18:53 +00:00
pure ExitSuccess
2021-03-01 23:15:03 +00:00
VLeft err @ ( V ( BuildFailed tmpdir _ ) ) -> do
2020-10-23 23:06:53 +00:00
case keepDirs settings of
2021-05-14 21:09:45 +00:00
Never -> myLoggerT loggerConfig $ ( $ ( logError ) $ T . pack $ prettyShow err )
_ -> myLoggerT loggerConfig $ ( $ ( logError ) [ i |# { prettyShow err }
2020-07-28 23:43:00 +00:00
Check the logs at # { logsDir } and the build directory # { tmpdir } for more clues .
2020-05-10 22:18:53 +00:00
Make sure to clean up # { tmpdir } afterwards .| ] )
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
2021-03-01 23:15:03 +00:00
$ ( logError ) $ T . pack $ prettyShow e
2020-07-28 23:43:00 +00:00
$ ( logError ) [ i | Also check the logs in # { logsDir } | ]
2020-05-10 22:18:53 +00:00
pure $ ExitFailure 3
let installCabal InstallOptions { .. } =
2020-09-19 09:52:12 +00:00
( case instBindist of
2021-05-14 21:09:45 +00:00
Nothing -> runInstTool instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin ( _tvVersion v )
2021-02-22 20:55:05 +00:00
pure vi
2021-07-18 12:39:49 +00:00
Just uri -> do
s' <- appState
runInstTool' s' { settings = settings { noVerify = True } } instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist
( DownloadInfo uri Nothing " " )
( _tvVersion v )
pure vi
2020-05-10 22:18:53 +00:00
)
>>= \ case
2021-02-22 20:55:05 +00:00
VRight vi -> do
2021-03-11 16:03:51 +00:00
runLogger $ $ ( logInfo ) " Cabal installation successful "
forM_ ( _viPostInstall =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
2020-05-10 22:18:53 +00:00
pure ExitSuccess
VLeft ( V ( AlreadyInstalled _ v ) ) -> do
runLogger $ $ ( logWarn )
2021-01-11 07:12:19 +00:00
[ i | Cabal ver # { prettyVer v } already installed ; if you really want to reinstall it , you may want to run 'ghcup rm cabal # { prettyVer v } ' f i r s t | ]
2020-05-10 22:18:53 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ do
2021-03-01 23:15:03 +00:00
$ ( logError ) $ T . pack $ prettyShow e
2020-07-28 23:43:00 +00:00
$ ( logError ) [ i | Also check the logs in # { logsDir } | ]
2020-05-10 22:18:53 +00:00
pure $ ExitFailure 4
2020-09-20 15:57:16 +00:00
let installHLS InstallOptions { .. } =
( case instBindist of
2021-05-14 21:09:45 +00:00
Nothing -> runInstTool instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin ( _tvVersion v )
2021-02-22 20:55:05 +00:00
pure vi
2021-07-18 12:39:49 +00:00
Just uri -> do
s' <- appState
runInstTool' s' { settings = settings { noVerify = True } } instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist
( DownloadInfo uri Nothing " " )
( _tvVersion v )
pure vi
2020-09-20 15:57:16 +00:00
)
>>= \ case
2021-02-22 20:55:05 +00:00
VRight vi -> do
2021-03-11 16:03:51 +00:00
runLogger $ $ ( logInfo ) " HLS installation successful "
forM_ ( _viPostInstall =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
2020-09-20 15:57:16 +00:00
pure ExitSuccess
VLeft ( V ( AlreadyInstalled _ v ) ) -> do
runLogger $ $ ( logWarn )
2021-01-11 07:12:19 +00:00
[ i | HLS ver # { prettyVer v } already installed ; if you really want to reinstall it , you may want to run 'ghcup rm hls # { prettyVer v } ' f i r s t | ]
2020-09-20 15:57:16 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ do
2021-03-01 23:15:03 +00:00
$ ( logError ) $ T . pack $ prettyShow e
2020-09-20 15:57:16 +00:00
$ ( logError ) [ i | Also check the logs in # { logsDir } | ]
pure $ ExitFailure 4
2021-05-14 22:31:36 +00:00
let installStack InstallOptions { .. } =
( case instBindist of
2021-05-14 21:09:45 +00:00
Nothing -> runInstTool instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin ( _tvVersion v )
2021-05-14 22:31:36 +00:00
pure vi
2021-07-18 12:39:49 +00:00
Just uri -> do
s' <- appState
runInstTool' s' { settings = settings { noVerify = True } } instPlatform $ do
( v , vi ) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
( DownloadInfo uri Nothing " " )
( _tvVersion v )
pure vi
2021-05-14 22:31:36 +00:00
)
>>= \ 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 )
[ i | Stack ver # { prettyVer v } already installed ; if you really want to reinstall it , you may want to run 'ghcup rm stack # { prettyVer v } ' f i r s t | ]
pure ExitSuccess
VLeft e -> do
runLogger $ do
$ ( logError ) $ T . pack $ prettyShow e
$ ( logError ) [ i | Also check the logs in # { logsDir } | ]
pure $ ExitFailure 4
2020-09-20 15:57:16 +00:00
2021-07-18 12:39:49 +00:00
let setGHC' SetOptions { sToolVer } =
case sToolVer of
( SetToolVersion v ) -> runLeanSetGHC ( liftE $ setGHC v SetGHCOnly >> pure v )
_ -> runSetGHC ( do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
2020-05-10 22:18:53 +00:00
>>= \ case
2021-03-11 16:03:51 +00:00
VRight GHCTargetVersion { .. } -> do
2020-05-10 22:18:53 +00:00
runLogger
$ $ ( logInfo )
[ i | GHC # { prettyVer _tvVersion } successfully set as default version # { maybe " " ( " for cross target " <> ) _tvTarget } | ]
pure ExitSuccess
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-05-10 22:18:53 +00:00
pure $ ExitFailure 5
2021-07-18 12:39:49 +00:00
let setCabal' SetOptions { sToolVer } =
case sToolVer of
( SetToolVersion v ) -> runLeanSetCabal ( liftE $ setCabal ( _tvVersion v ) >> pure v )
_ -> runSetCabal ( do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal ( _tvVersion v )
pure v
)
2020-05-10 22:18:53 +00:00
>>= \ case
2021-03-11 16:03:51 +00:00
VRight GHCTargetVersion { .. } -> do
2021-02-25 17:21:25 +00:00
runLogger
$ $ ( logInfo )
[ i | Cabal # { prettyVer _tvVersion } successfully set as default version | ]
pure ExitSuccess
2020-05-10 22:18:53 +00:00
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-05-10 22:18:53 +00:00
pure $ ExitFailure 14
2021-07-18 12:39:49 +00:00
let setHLS' SetOptions { sToolVer } =
case sToolVer of
( SetToolVersion v ) -> runLeanSetHLS ( liftE $ setHLS ( _tvVersion v ) >> pure v )
_ -> runSetHLS ( do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS ( _tvVersion v )
pure v
)
2020-09-20 15:57:16 +00:00
>>= \ case
2021-03-11 16:03:51 +00:00
VRight GHCTargetVersion { .. } -> do
2021-02-25 17:21:25 +00:00
runLogger
$ $ ( logInfo )
[ i | HLS # { prettyVer _tvVersion } successfully set as default version | ]
pure ExitSuccess
2020-09-20 15:57:16 +00:00
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-09-20 15:57:16 +00:00
pure $ ExitFailure 14
2021-07-18 12:39:49 +00:00
let setStack' SetOptions { sToolVer } =
case sToolVer of
( SetToolVersion v ) -> runSetCabal ( liftE $ setStack ( _tvVersion v ) >> pure v )
_ -> runSetCabal ( do
v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack ( _tvVersion v )
pure v
)
2021-05-14 22:31:36 +00:00
>>= \ case
VRight GHCTargetVersion { .. } -> do
runLogger
$ $ ( logInfo )
[ i | Stack # { prettyVer _tvVersion } successfully set as default version | ]
pure ExitSuccess
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 14
2020-05-10 22:18:53 +00:00
let rmGHC' RmOptions { .. } =
2021-03-11 16:03:51 +00:00
runRm ( do
2021-02-22 20:55:05 +00:00
liftE $
rmGHCVer ghcVer
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-03-07 11:02:13 +00:00
pure ( getVersionInfo ( _tvVersion ghcVer ) GHC dls )
2020-05-10 22:18:53 +00:00
)
>>= \ case
2021-02-22 20:55:05 +00:00
VRight vi -> do
2021-03-11 16:03:51 +00:00
forM_ ( _viPostRemove =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
pure ExitSuccess
2020-05-10 22:18:53 +00:00
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-05-10 22:18:53 +00:00
pure $ ExitFailure 7
let rmCabal' tv =
2021-03-11 16:03:51 +00:00
runRm ( do
2021-02-22 20:55:05 +00:00
liftE $
rmCabalVer tv
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-03-07 11:02:13 +00:00
pure ( getVersionInfo tv Cabal dls )
2020-05-10 22:18:53 +00:00
)
>>= \ case
2021-02-22 20:55:05 +00:00
VRight vi -> do
2021-03-11 16:03:51 +00:00
forM_ ( _viPostRemove =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
pure ExitSuccess
2020-05-10 22:18:53 +00:00
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-05-10 22:18:53 +00:00
pure $ ExitFailure 15
2020-09-20 15:57:16 +00:00
let rmHLS' tv =
2021-03-11 16:03:51 +00:00
runRm ( do
2021-02-22 20:55:05 +00:00
liftE $
rmHLSVer tv
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-03-07 11:02:13 +00:00
pure ( getVersionInfo tv HLS dls )
2020-09-20 15:57:16 +00:00
)
>>= \ case
2021-02-22 20:55:05 +00:00
VRight vi -> do
2021-03-11 16:03:51 +00:00
forM_ ( _viPostRemove =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
pure ExitSuccess
2020-09-20 15:57:16 +00:00
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-09-20 15:57:16 +00:00
pure $ ExitFailure 15
2020-05-10 22:18:53 +00:00
2021-05-14 22:31:36 +00:00
let rmStack' tv =
runRm ( do
liftE $
rmStackVer tv
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 22:31:36 +00:00
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
2020-05-10 22:18:53 +00:00
res <- case optCommand of
2020-07-06 20:39:16 +00:00
# if defined ( BRICK )
2021-05-14 21:09:45 +00:00
Interactive -> do
2021-07-18 21:29:09 +00:00
s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
2020-07-06 20:39:16 +00:00
# endif
2020-05-10 22:18:53 +00:00
Install ( Right iopts ) -> do
runLogger ( $ ( logWarn ) [ i | This is an old - style command for installing GHC . Use 'ghcup install ghc' instead .| ] )
installGHC iopts
Install ( Left ( InstallGHC iopts ) ) -> installGHC iopts
Install ( Left ( InstallCabal iopts ) ) -> installCabal iopts
2020-09-20 15:57:16 +00:00
Install ( Left ( InstallHLS iopts ) ) -> installHLS iopts
2021-05-14 22:31:36 +00:00
Install ( Left ( InstallStack iopts ) ) -> installStack iopts
2020-05-10 22:18:53 +00:00
InstallCabalLegacy iopts -> do
runLogger ( $ ( logWarn ) [ i | This is an old - style command for installing cabal . Use 'ghcup install cabal' instead .| ] )
installCabal iopts
Set ( Right sopts ) -> do
runLogger ( $ ( logWarn ) [ i | This is an old - style command for setting GHC . Use 'ghcup set ghc' instead .| ] )
setGHC' sopts
Set ( Left ( SetGHC sopts ) ) -> setGHC' sopts
Set ( Left ( SetCabal sopts ) ) -> setCabal' sopts
2020-09-20 15:57:16 +00:00
Set ( Left ( SetHLS sopts ) ) -> setHLS' sopts
2021-05-14 22:31:36 +00:00
Set ( Left ( SetStack sopts ) ) -> setStack' sopts
2020-01-11 20:15:05 +00:00
2021-03-11 16:03:51 +00:00
List ListOptions { .. } ->
runListGHC ( do
2021-05-14 21:09:45 +00:00
l <- listVersions loTool lCriteria
2020-07-13 16:27:21 +00:00
liftIO $ printListResult lRawFormat l
pure ExitSuccess
2020-04-17 16:54:21 +00:00
)
2020-01-11 20:15:05 +00:00
2020-05-10 22:18:53 +00:00
Rm ( Right rmopts ) -> do
runLogger ( $ ( logWarn ) [ i | This is an old - style command for removing GHC . Use 'ghcup rm ghc' instead .| ] )
rmGHC' rmopts
Rm ( Left ( RmGHC rmopts ) ) -> rmGHC' rmopts
Rm ( Left ( RmCabal rmopts ) ) -> rmCabal' rmopts
2020-09-20 15:57:16 +00:00
Rm ( Left ( RmHLS rmopts ) ) -> rmHLS' rmopts
2021-05-14 22:31:36 +00:00
Rm ( Left ( RmStack rmopts ) ) -> rmStack' rmopts
2020-01-11 20:15:05 +00:00
2020-04-17 16:54:21 +00:00
DInfo ->
2021-03-11 16:03:51 +00:00
do runDebugInfo $ liftE getDebugInfo
2020-01-11 20:15:05 +00:00
>>= \ case
2020-04-17 16:26:55 +00:00
VRight dinfo -> do
putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 8
2020-01-11 20:15:05 +00:00
2021-07-20 19:45:24 +00:00
Compile ( CompileGHC GHCCompileOptions { hadrian = True , crossTarget = Just _ } ) -> do
runLogger $ $ ( logError ) " Hadrian cross compile support is not yet implemented! "
pure $ ExitFailure 9
2020-04-25 10:06:41 +00:00
Compile ( CompileGHC GHCCompileOptions { .. } ) ->
2021-03-11 16:03:51 +00:00
runCompileGHC ( do
2021-04-28 16:45:48 +00:00
case targetGhc of
Left targetVer -> do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-04-28 16:45:48 +00:00
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 ()
2021-05-14 21:09:45 +00:00
targetVer <- liftE $ compileGHC
2021-04-28 16:45:48 +00:00
( first ( GHCTargetVersion crossTarget ) targetGhc )
2021-06-05 20:26:35 +00:00
ovewrwiteVer
2020-10-25 09:54:04 +00:00
bootstrapGhc
jobs
buildConfig
patchDir
addConfArgs
2021-07-20 11:08:17 +00:00
buildFlavour
2021-07-20 19:45:24 +00:00
hadrian
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-04-28 16:45:48 +00:00
let vi = getVersionInfo ( _tvVersion targetVer ) GHC dls
2021-02-22 20:55:05 +00:00
when setCompile $ void $ liftE $
2021-04-28 16:45:48 +00:00
setGHC targetVer SetGHCOnly
2021-07-20 09:42:36 +00:00
pure ( vi , targetVer )
2020-04-17 16:54:21 +00:00
)
2020-01-11 20:15:05 +00:00
>>= \ case
2021-07-20 09:42:36 +00:00
VRight ( vi , tv ) -> do
2020-01-11 20:15:05 +00:00
runLogger $ $ ( logInfo )
2021-03-11 16:03:51 +00:00
" GHC successfully compiled and installed "
forM_ ( _viPostInstall =<< vi ) $ \ msg ->
2021-02-22 20:55:05 +00:00
runLogger $ $ ( logInfo ) msg
2021-07-20 09:42:36 +00:00
putStr ( T . unpack $ tVerToText tv )
2020-04-17 16:26:55 +00:00
pure ExitSuccess
VLeft ( V ( AlreadyInstalled _ v ) ) -> do
2020-01-11 20:15:05 +00:00
runLogger $ $ ( logWarn )
2021-01-11 07:12:19 +00:00
[ i | GHC ver # { prettyVer v } already installed ; if you really want to reinstall it , you may want to run 'ghcup rm ghc # { prettyVer v } ' f i r s t | ]
2020-04-17 16:26:55 +00:00
pure ExitSuccess
2021-03-01 23:15:03 +00:00
VLeft err @ ( V ( BuildFailed tmpdir _ ) ) -> do
2020-10-23 23:06:53 +00:00
case keepDirs settings of
2021-05-14 21:09:45 +00:00
Never -> myLoggerT loggerConfig $ $ ( logError ) $ T . pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ( $ ( logError ) [ i |# { prettyShow err }
2020-07-28 23:43:00 +00:00
Check the logs at # { logsDir } and the build directory # { tmpdir } for more clues .
2020-04-22 16:12:40 +00:00
Make sure to clean up # { tmpdir } afterwards .| ] )
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 9
VLeft e -> do
2021-03-01 23:15:03 +00:00
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
2020-04-17 16:26:55 +00:00
pure $ ExitFailure 9
2020-01-11 20:15:05 +00:00
2021-07-18 12:39:49 +00:00
Whereis WhereisOptions { .. } ( WhereisTool tool ( Just ( ToolVersion v ) ) ) ->
runLeanWhereIs ( do
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \ case
VRight r -> do
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 30
2021-07-12 13:40:42 +00:00
Whereis WhereisOptions { .. } ( WhereisTool tool whereVer ) ->
runWhereIs ( do
( v , _ ) <- liftE $ fromVersion whereVer tool
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \ case
VRight r -> do
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 30
2021-07-15 11:32:48 +00:00
Upgrade uOpts force' -> do
2020-01-11 20:15:05 +00:00
target <- case uOpts of
2021-05-14 21:09:45 +00:00
UpgradeInplace -> Just <$> liftIO getExecutablePath
2020-01-11 20:15:05 +00:00
( UpgradeAt p ) -> pure $ Just p
2021-06-13 06:36:20 +00:00
UpgradeGHCupDir -> pure ( Just ( binDir </> " ghcup " <> exeExt ) )
2020-01-11 20:15:05 +00:00
2021-07-27 18:57:51 +00:00
runUpgrade ( do
v' <- liftE $ upgradeGHCup target force'
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure ( v' , dls )
) >>= \ case
VRight ( v' , dls ) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $ ( logInfo )
[ i | Successfully upgraded GHCup to version # { pretty_v } | ]
forM_ ( _viPostInstall vi ) $ \ msg ->
runLogger $ $ ( logInfo ) msg
pure ExitSuccess
VLeft ( V NoUpdate ) -> do
runLogger $ $ ( logWarn ) [ i | No GHCup update available | ]
pure ExitSuccess
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 11
2020-04-17 16:54:21 +00:00
2021-07-18 12:39:49 +00:00
ToolRequirements -> do
s' <- appState
flip runReaderT s'
$ runLogger
( runE
@ '[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
GHCupInfo { .. } <- lift getGHCupInfo
platform' <- liftE getPlatform
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
liftIO $ T . hPutStr stdout ( prettyRequirements req )
)
>>= \ case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 12
2020-04-17 16:26:55 +00:00
2021-03-11 16:03:51 +00:00
ChangeLog ChangeLogOptions { .. } -> do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
2020-04-18 13:05:05 +00:00
let tool = fromMaybe GHC clTool
ver' = maybe
( Right Latest )
( \ case
2020-04-25 10:06:41 +00:00
ToolVersion tv -> Left ( _tvVersion tv ) -- FIXME: ugly sharing of ToolVersion
2020-04-18 13:05:05 +00:00
ToolTag t -> Right t
)
clToolVer
muri = getChangeLog dls tool ver'
case muri of
Nothing -> do
runLogger
( $ ( logWarn )
[ i | Could not find ChangeLog for # { tool } , version # { either ( T . unpack . prettyVer ) show ver' } | ]
)
pure ExitSuccess
Just uri -> do
2021-07-22 13:45:08 +00:00
s' <- appState
pfreq <- flip runReaderT s' getPlatformReq
2020-04-18 13:05:05 +00:00
let uri' = T . unpack . decUTF8Safe . serializeURIRef' $ uri
2020-07-13 21:10:17 +00:00
cmd = case _rPlatform pfreq of
Darwin -> " open "
Linux _ -> " xdg-open "
FreeBSD -> " xdg-open "
2021-05-14 21:09:45 +00:00
Windows -> " start "
2020-07-13 21:10:17 +00:00
2020-04-18 13:05:05 +00:00
if clOpen
2021-07-18 12:39:49 +00:00
then do
flip runReaderT s' $
exec cmd
[ T . unpack $ decUTF8Safe $ serializeURIRef' uri ]
Nothing
Nothing
>>= \ case
Right _ -> pure ExitSuccess
Left e -> runLogger ( $ ( logError ) [ i |# { e } | ] )
>> pure ( ExitFailure 13 )
2020-04-18 13:05:05 +00:00
else putStrLn uri' >> pure ExitSuccess
2021-07-22 13:45:08 +00:00
Nuke -> do
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' ( do
2021-07-02 21:26:07 +00:00
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. "
2021-06-29 03:17:44 +00:00
liftIO $ threadDelay 10000000 -- wait 10s
2021-07-02 21:26:07 +00:00
lift $ $ logInfo " Initiating Nuclear Sequence 🚀🚀🚀 "
lift $ $ logInfo " Nuking in 3...2...1 "
2021-06-22 13:23:18 +00:00
2021-07-02 21:26:07 +00:00
lInstalled <- lift $ listVersions Nothing ( Just ListInstalled )
2021-06-29 03:17:44 +00:00
forM_ lInstalled ( liftE . rmTool )
2021-07-02 21:26:07 +00:00
lift rmGhcupDirs
2021-06-29 03:17:44 +00:00
) >>= \ case
2021-07-02 21:26:07 +00:00
VRight leftOverFiles
| null leftOverFiles -> do
2021-06-29 03:17:44 +00:00
runLogger $ $ logInfo " Nuclear Annihilation complete! "
pure ExitSuccess
2021-07-02 21:26:07 +00:00
| otherwise -> do
2021-07-26 16:13:41 +00:00
runLogger $ $ logError " These Files have survived Nuclear Annihilation, you may remove them manually. "
2021-07-02 21:26:07 +00:00
forM_ leftOverFiles putStrLn
2021-06-29 03:17:44 +00:00
pure ExitSuccess
2021-06-26 16:26:52 +00:00
2021-06-29 03:17:44 +00:00
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 15
2021-07-19 14:49:18 +00:00
Prefetch pfCom ->
runPrefetch ( do
case pfCom of
PrefetchGHC
( PrefetchGHCOptions pfGHCSrc pfCacheDir ) mt -> do
forM_ pfCacheDir ( liftIO . createDirRecursive' )
( v , _ ) <- liftE $ fromVersion mt GHC
if pfGHCSrc
then liftE $ fetchGHCSrc ( _tvVersion v ) pfCacheDir
else liftE $ fetchToolBindist ( _tvVersion v ) GHC pfCacheDir
PrefetchCabal ( PrefetchOptions { pfCacheDir } ) mt -> do
forM_ pfCacheDir ( liftIO . createDirRecursive' )
( v , _ ) <- liftE $ fromVersion mt Cabal
liftE $ fetchToolBindist ( _tvVersion v ) Cabal pfCacheDir
PrefetchHLS ( PrefetchOptions { pfCacheDir } ) mt -> do
forM_ pfCacheDir ( liftIO . createDirRecursive' )
( v , _ ) <- liftE $ fromVersion mt HLS
liftE $ fetchToolBindist ( _tvVersion v ) HLS pfCacheDir
PrefetchStack ( PrefetchOptions { pfCacheDir } ) mt -> do
forM_ pfCacheDir ( liftIO . createDirRecursive' )
( v , _ ) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist ( _tvVersion v ) Stack pfCacheDir
PrefetchMetadata -> do
_ <- liftE $ getDownloadsF
pure " "
) >>= \ case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ $ ( logError ) $ T . pack $ prettyShow e
pure $ ExitFailure 15
2021-06-22 17:45:13 +00:00
2021-06-18 09:39:01 +00:00
2020-04-17 16:26:55 +00:00
case res of
ExitSuccess -> pure ()
2020-04-17 18:50:23 +00:00
ef @ ( ExitFailure _ ) -> exitWith ef
2021-06-18 09:31:32 +00:00
2020-01-11 20:15:05 +00:00
pure ()
2021-07-18 12:39:49 +00:00
fromVersion :: ( MonadLogger m
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
2021-05-14 21:09:45 +00:00
=> Maybe ToolVersion
2020-01-11 20:15:05 +00:00
-> Tool
2021-07-18 12:39:49 +00:00
-> Excepts
' [ T a g N o t F o u n d
, NextVerNotFound
, NoToolVersionSet
] m ( GHCTargetVersion , Maybe VersionInfo )
2021-05-14 21:09:45 +00:00
fromVersion tv = fromVersion' ( toSetToolVer tv )
2021-02-25 17:21:25 +00:00
2021-07-18 12:39:49 +00:00
fromVersion' :: ( MonadLogger m
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
2021-05-14 21:09:45 +00:00
=> SetToolVersion
2021-02-25 17:21:25 +00:00
-> Tool
2021-07-18 12:39:49 +00:00
-> Excepts
' [ T a g N o t F o u n d
, NextVerNotFound
, NoToolVersionSet
] m ( GHCTargetVersion , Maybe VersionInfo )
2021-05-14 21:09:45 +00:00
fromVersion' SetRecommended tool = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
( \ ( x , y ) -> ( mkTVer x , Just y ) ) <$> getRecommended dls tool
2021-02-22 20:55:05 +00:00
?? TagNotFound Recommended tool
2021-05-14 21:09:45 +00:00
fromVersion' ( SetToolVersion v ) tool = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
let vi = getVersionInfo ( _tvVersion v ) tool dls
2020-04-25 10:06:41 +00:00
case pvp $ prettyVer ( _tvVersion v ) of
2021-02-22 20:55:05 +00:00
Left _ -> pure ( v , vi )
2020-04-22 14:13:58 +00:00
Right ( PVP ( major' :| [ minor' ] ) ) ->
2021-05-14 21:09:45 +00:00
case getLatestGHCFor ( fromIntegral major' ) ( fromIntegral minor' ) dls of
2021-03-07 11:02:13 +00:00
Just ( v' , vi' ) -> pure ( GHCTargetVersion ( _tvTarget v ) v' , Just vi' )
2021-02-22 20:55:05 +00:00
Nothing -> pure ( v , vi )
Right _ -> pure ( v , vi )
2021-05-14 21:09:45 +00:00
fromVersion' ( SetToolTag Latest ) tool = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
( \ ( x , y ) -> ( mkTVer x , Just y ) ) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' ( SetToolTag Recommended ) tool = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
( \ ( x , y ) -> ( mkTVer x , Just y ) ) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' ( SetToolTag ( Base pvp'' ) ) GHC = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-05-14 21:09:45 +00:00
( \ ( x , y ) -> ( mkTVer x , Just y ) ) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound ( Base pvp'' ) GHC
fromVersion' SetNext tool = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-02-25 17:21:25 +00:00
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
2021-05-14 22:31:36 +00:00
Stack -> do
set <- stackSet !? NoToolVersionSet tool
stacks <- rights <$> lift getInstalledStacks
( fmap ( GHCTargetVersion Nothing )
. headMay
. tail
. dropWhile ( /= set )
. cycle
. sort
$ stacks ) ?? NoToolVersionSet tool
2021-02-25 17:21:25 +00:00
GHCup -> fail " GHCup cannot be set "
2021-05-14 21:09:45 +00:00
let vi = getVersionInfo ( _tvVersion next ) tool dls
2021-02-25 17:21:25 +00:00
pure ( next , vi )
2021-05-14 21:09:45 +00:00
fromVersion' ( SetToolTag t' ) tool =
2020-04-22 00:33:35 +00:00
throwE $ TagNotFound t' tool
2020-01-11 20:15:05 +00:00
2020-04-22 10:30:02 +00:00
printListResult :: Bool -> [ ListResult ] -> IO ()
printListResult raw lr = do
2020-11-25 09:36:34 +00:00
no_color <- isJust <$> lookupEnv " NO_COLOR "
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 = " "
2020-01-11 20:15:05 +00:00
let
2020-09-22 19:05:59 +00:00
rows =
( \ x -> if raw
then x
else [ color Green " " , " Tool " , " Version " , " Tags " , " Notes " ] : x
)
. fmap
2020-01-11 20:15:05 +00:00
( \ ListResult { .. } ->
2020-04-22 10:30:02 +00:00
let marks = if
2021-05-14 21:09:45 +00:00
# if defined ( IS_WINDOWS )
| lSet -> ( color Green " IS " )
| lInstalled -> ( color Green " I " )
| otherwise -> ( color Red " X " )
# else
2020-04-22 10:30:02 +00:00
| lSet -> ( color Green " ✔✔ " )
2020-09-22 19:05:59 +00:00
| lInstalled -> ( color Green " ✓ " )
| otherwise -> ( color Red " ✗ " )
2021-05-14 21:09:45 +00:00
# endif
2020-09-22 19:05:59 +00:00
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 )
2020-10-09 20:55:33 +00:00
, intercalate " , " $ ( filter ( /= " " ) . fmap printTag $ sort lTag )
2020-09-22 19:05:59 +00:00
, intercalate " , "
$ ( if hlsPowered
2020-11-25 09:36:34 +00:00
then [ color Green " hls-powered " ]
2020-09-22 19:05:59 +00:00
else mempty
)
2020-11-25 09:36:34 +00:00
++ ( if fromSrc then [ color Blue " compiled " ] else mempty )
++ ( if lStray then [ color Yellow " stray " ] else mempty )
2020-09-22 19:05:59 +00:00
++ ( if lNoBindist
2020-11-25 09:36:34 +00:00
then [ color Red " no-bindist " ]
2020-09-22 19:05:59 +00:00
else mempty
)
]
2020-01-11 20:15:05 +00:00
)
2020-09-22 19:05:59 +00:00
$ 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
2020-04-22 00:33:35 +00:00
where
2020-03-09 21:21:22 +00:00
2020-09-22 19:05:59 +00:00
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
2021-07-18 12:39:49 +00:00
checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
2020-10-23 23:06:53 +00:00
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadFail m
, MonadLogger m
)
2021-05-14 21:09:45 +00:00
=> m ()
checkForUpdates = do
2021-07-18 12:39:49 +00:00
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
2021-05-14 21:09:45 +00:00
lInstalled <- listVersions Nothing ( Just ListInstalled )
2021-04-01 15:21:00 +00:00
let latestInstalled tool = ( fmap lVer . lastMay . filter ( \ lr -> lTool lr == tool ) ) lInstalled
2021-02-22 20:55:05 +00:00
forM_ ( getLatest dls GHCup ) $ \ ( l , _ ) -> do
2020-03-09 21:21:22 +00:00
( Right ghc_ver ) <- pure $ version $ prettyPVP ghcUpVer
when ( l > ghc_ver )
2020-07-13 16:27:21 +00:00
$ $ ( logWarn )
2020-03-09 21:21:22 +00:00
[ i | New GHCup version available : # { prettyVer l } . To upgrade , run 'ghcup upgrade' | ]
2020-04-17 15:12:59 +00:00
2021-02-22 20:55:05 +00:00
forM_ ( getLatest dls GHC ) $ \ ( l , _ ) -> do
2021-04-01 15:21:00 +00:00
let mghc_ver = latestInstalled GHC
2020-04-18 18:20:18 +00:00
forM mghc_ver $ \ ghc_ver ->
when ( l > ghc_ver )
2020-07-13 16:27:21 +00:00
$ $ ( logWarn )
2020-05-10 22:18:53 +00:00
[ i | New GHC version available : # { prettyVer l } . To upgrade , run 'ghcup install ghc # { prettyVer l } '| ]
2020-04-18 18:20:18 +00:00
2021-02-22 20:55:05 +00:00
forM_ ( getLatest dls Cabal ) $ \ ( l , _ ) -> do
2021-04-01 15:21:00 +00:00
let mcabal_ver = latestInstalled Cabal
2020-04-18 18:20:18 +00:00
forM mcabal_ver $ \ cabal_ver ->
when ( l > cabal_ver )
2020-07-13 16:27:21 +00:00
$ $ ( logWarn )
2020-05-10 22:18:53 +00:00
[ i | New Cabal version available : # { prettyVer l } . To upgrade , run 'ghcup install cabal # { prettyVer l } '| ]
2020-04-18 18:20:18 +00:00
2021-02-22 20:55:05 +00:00
forM_ ( getLatest dls HLS ) $ \ ( l , _ ) -> do
2021-04-01 15:21:00 +00:00
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \ hls_ver ->
when ( l > hls_ver )
2020-09-20 15:57:16 +00:00
$ $ ( logWarn )
[ i | New HLS version available : # { prettyVer l } . To upgrade , run 'ghcup install hls # { prettyVer l } '| ]
2021-05-14 22:31:36 +00:00
forM_ ( getLatest dls Stack ) $ \ ( l , _ ) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \ stack_ver ->
when ( l > stack_ver )
$ $ ( logWarn )
[ i | New Stack version available : # { prettyVer l } . To upgrade , run 'ghcup install stack # { prettyVer l } '| ]
2020-04-17 15:12:59 +00:00
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo { .. } = [ i | Debug Info
==========
2021-05-14 21:09:45 +00:00
GHCup base dir : # { diBaseDir }
GHCup bin dir : # { diBinDir }
GHCup GHC directory : # { diGHCDir }
GHCup cache directory : # { diCacheDir }
2021-03-01 23:15:03 +00:00
Architecture : # { prettyShow diArch }
Platform : # { prettyShow diPlatform }
2020-04-17 15:12:59 +00:00
Version : # { describe_result } | ]
2020-04-17 16:26:55 +00:00