Avoid module recompilation
This commit is contained in:
@@ -1,363 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
module GHCup.OptParse (
|
||||
module GHCup.OptParse.Common
|
||||
, module GHCup.OptParse.Install
|
||||
, module GHCup.OptParse.Test
|
||||
, module GHCup.OptParse.Set
|
||||
, module GHCup.OptParse.UnSet
|
||||
, module GHCup.OptParse.Rm
|
||||
, module GHCup.OptParse.Compile
|
||||
, module GHCup.OptParse.Config
|
||||
, module GHCup.OptParse.Whereis
|
||||
, module GHCup.OptParse.List
|
||||
#ifndef DISABLE_UPGRADE
|
||||
, module GHCup.OptParse.Upgrade
|
||||
#endif
|
||||
, module GHCup.OptParse.ChangeLog
|
||||
, module GHCup.OptParse.Prefetch
|
||||
, module GHCup.OptParse.GC
|
||||
, module GHCup.OptParse.DInfo
|
||||
, module GHCup.OptParse.Nuke
|
||||
, module GHCup.OptParse.ToolRequirements
|
||||
, module GHCup.OptParse.Run
|
||||
, module GHCup.OptParse
|
||||
) where
|
||||
|
||||
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.OptParse.Install
|
||||
import GHCup.OptParse.Test
|
||||
import GHCup.OptParse.Set
|
||||
import GHCup.OptParse.UnSet
|
||||
import GHCup.OptParse.Rm
|
||||
import GHCup.OptParse.Run
|
||||
import GHCup.OptParse.Compile
|
||||
import GHCup.OptParse.Config
|
||||
import GHCup.OptParse.Whereis
|
||||
import GHCup.OptParse.List
|
||||
#ifndef DISABLE_UPGRADE
|
||||
import GHCup.OptParse.Upgrade
|
||||
#endif
|
||||
import GHCup.OptParse.ChangeLog
|
||||
import GHCup.OptParse.Prefetch
|
||||
import GHCup.OptParse.GC
|
||||
import GHCup.OptParse.DInfo
|
||||
import GHCup.OptParse.ToolRequirements
|
||||
import GHCup.OptParse.Nuke
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
|
||||
|
||||
data Options = Options
|
||||
{
|
||||
-- global options
|
||||
optVerbose :: Maybe Bool
|
||||
, optCache :: Maybe Bool
|
||||
, optMetaCache :: Maybe Integer
|
||||
, optMetaMode :: Maybe MetaMode
|
||||
, optPlatform :: Maybe PlatformRequest
|
||||
, optUrlSource :: Maybe URI
|
||||
, optNoVerify :: Maybe Bool
|
||||
, optKeepDirs :: Maybe KeepDirs
|
||||
, optsDownloader :: Maybe Downloader
|
||||
, optNoNetwork :: Maybe Bool
|
||||
, optGpg :: Maybe GPGSetting
|
||||
-- commands
|
||||
, optCommand :: Command
|
||||
}
|
||||
|
||||
data Command
|
||||
= Install (Either InstallCommand InstallOptions)
|
||||
| Test TestCommand
|
||||
| InstallCabalLegacy InstallOptions
|
||||
| Set (Either SetCommand SetOptions)
|
||||
| UnSet UnsetCommand
|
||||
| List ListOptions
|
||||
| Rm (Either RmCommand RmOptions)
|
||||
| DInfo
|
||||
| Compile CompileCommand
|
||||
| Config ConfigCommand
|
||||
| Whereis WhereisOptions WhereisCommand
|
||||
#ifndef DISABLE_UPGRADE
|
||||
| Upgrade UpgradeOpts Bool Bool
|
||||
#endif
|
||||
| ToolRequirements ToolReqOpts
|
||||
| ChangeLog ChangeLogOptions
|
||||
| Nuke
|
||||
#if defined(BRICK)
|
||||
| Interactive
|
||||
#endif
|
||||
| Prefetch PrefetchCommand
|
||||
| GC GCOptions
|
||||
| Run RunOptions
|
||||
| PrintAppErrors
|
||||
|
||||
|
||||
|
||||
opts :: Parser Options
|
||||
opts =
|
||||
Options
|
||||
<$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
|
||||
<*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
|
||||
<*> optional (option auto (long "metadata-caching" <> metavar "SEC" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable"))
|
||||
<*> optional (option auto (long "metadata-fetching-mode" <> metavar "<Strict|Lax>" <> help "Whether to fail on metadata download failure (Strict) or fall back to cached version (Lax (default))"))
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader platformParser)
|
||||
( short 'p'
|
||||
<> long "platform"
|
||||
<> metavar "PLATFORM"
|
||||
<> help
|
||||
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
( short 's'
|
||||
<> long "url-source"
|
||||
<> metavar "URL"
|
||||
<> help "Alternative ghcup download info url"
|
||||
<> internal
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
<*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
|
||||
<*> optional (option
|
||||
(eitherReader keepOnParser)
|
||||
( long "keep"
|
||||
<> metavar "<always|errors|never>"
|
||||
<> help
|
||||
"Keep build directories? (default: errors)"
|
||||
<> hidden
|
||||
<> completer (listCompleter ["always", "errors", "never"])
|
||||
))
|
||||
<*> optional (option
|
||||
(eitherReader downloaderParser)
|
||||
( long "downloader"
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
<> metavar "<internal|curl|wget>"
|
||||
<> help
|
||||
"Downloader to use (default: internal)"
|
||||
<> completer (listCompleter ["internal", "curl", "wget"])
|
||||
#else
|
||||
<> metavar "<curl|wget>"
|
||||
<> help
|
||||
"Downloader to use (default: curl)"
|
||||
<> completer (listCompleter ["curl", "wget"])
|
||||
#endif
|
||||
<> hidden
|
||||
))
|
||||
<*> invertableSwitch "offline" (Just 'o') False (help "Don't do any network calls, trying cached assets and failing if missing.")
|
||||
<*> optional (option
|
||||
(eitherReader gpgParser)
|
||||
( long "gpg"
|
||||
<> metavar "<strict|lax|none>"
|
||||
<> help
|
||||
"GPG verification (default: none)"
|
||||
<> completer (listCompleter ["strict", "lax", "none"])
|
||||
))
|
||||
<*> com
|
||||
where
|
||||
parseUri s' =
|
||||
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
|
||||
|
||||
|
||||
com :: Parser Command
|
||||
com =
|
||||
subparser
|
||||
#if defined(BRICK)
|
||||
( command
|
||||
"tui"
|
||||
( (\_ -> Interactive)
|
||||
<$> info
|
||||
helper
|
||||
( progDesc "Start the interactive GHCup UI"
|
||||
)
|
||||
)
|
||||
<> command
|
||||
#else
|
||||
( command
|
||||
#endif
|
||||
"install"
|
||||
( Install
|
||||
<$> info
|
||||
(installParser <**> helper)
|
||||
( progDesc "Install or update GHC/cabal/HLS/stack"
|
||||
<> footerDoc (Just $ text installToolFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"test"
|
||||
(info
|
||||
(Test <$> testParser <**> helper)
|
||||
( progDesc "Run tests for a tool (if any) [EXPERIMENTAL!]"
|
||||
<> footerDoc (Just $ text testFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"set"
|
||||
(info
|
||||
(Set <$> setParser <**> helper)
|
||||
( progDesc "Set currently active GHC/cabal version"
|
||||
<> footerDoc (Just $ text setFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"unset"
|
||||
(info
|
||||
(UnSet <$> unsetParser <**> helper)
|
||||
( progDesc "Unset currently active GHC/cabal version"
|
||||
<> footerDoc (Just $ text unsetFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"rm"
|
||||
(info
|
||||
(Rm <$> rmParser <**> helper)
|
||||
( progDesc "Remove a GHC/cabal/HLS/stack version"
|
||||
<> footerDoc (Just $ text rmFooter)
|
||||
)
|
||||
)
|
||||
|
||||
<> command
|
||||
"list"
|
||||
(info (List <$> listOpts <**> helper)
|
||||
(progDesc "Show available GHCs and other tools"
|
||||
<> footerDoc (Just $ text listToolFooter))
|
||||
)
|
||||
<> command
|
||||
"upgrade"
|
||||
(info
|
||||
( (Upgrade <$> upgradeOptsP <*> switch
|
||||
(short 'f' <> long "force" <> help "Force update")
|
||||
<*> switch
|
||||
(long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)")
|
||||
)
|
||||
<**> helper
|
||||
)
|
||||
(progDesc "Upgrade ghcup")
|
||||
)
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> info (compileP <**> helper)
|
||||
(progDesc "Compile a tool from source")
|
||||
)
|
||||
<> command
|
||||
"whereis"
|
||||
(info
|
||||
( (Whereis
|
||||
<$> (WhereisOptions <$> switch (short 'd' <> long "directory" <> help "return directory of the binary instead of the binary location"))
|
||||
<*> whereisP
|
||||
) <**> helper
|
||||
)
|
||||
(progDesc "Find a tools location"
|
||||
<> footerDoc ( Just $ text whereisFooter ))
|
||||
)
|
||||
<> command
|
||||
"prefetch"
|
||||
(info
|
||||
( (Prefetch
|
||||
<$> prefetchP
|
||||
) <**> helper
|
||||
)
|
||||
(progDesc "Prefetch assets"
|
||||
<> footerDoc ( Just $ text prefetchFooter ))
|
||||
)
|
||||
<> command
|
||||
"gc"
|
||||
(info
|
||||
( (GC
|
||||
<$> gcP
|
||||
) <**> helper
|
||||
)
|
||||
(progDesc "Garbage collection"
|
||||
<> footerDoc ( Just $ text gcFooter ))
|
||||
)
|
||||
<> command
|
||||
"run"
|
||||
(Run
|
||||
<$>
|
||||
info
|
||||
(runOpts <**> helper)
|
||||
(progDesc "Run a command with the given tool in PATH"
|
||||
<> footerDoc ( Just $ text runFooter )
|
||||
)
|
||||
)
|
||||
<> commandGroup "Main commands:"
|
||||
)
|
||||
<|> subparser
|
||||
( command
|
||||
"debug-info"
|
||||
((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
|
||||
<> command
|
||||
"tool-requirements"
|
||||
( ToolRequirements
|
||||
<$> info (toolReqP <**> helper)
|
||||
(progDesc "Show the requirements for ghc/cabal")
|
||||
)
|
||||
<> command
|
||||
"changelog"
|
||||
(info
|
||||
(fmap ChangeLog changelogP <**> helper)
|
||||
( progDesc "Find/show changelog"
|
||||
<> footerDoc (Just $ text changeLogFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"config"
|
||||
( Config
|
||||
<$> info (configP <**> helper)
|
||||
(progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
|
||||
)
|
||||
<> commandGroup "Other commands:"
|
||||
<> hidden
|
||||
)
|
||||
<|> subparser
|
||||
( command
|
||||
"install-cabal"
|
||||
(info
|
||||
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
|
||||
( progDesc "Install or update cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
)
|
||||
<> internal
|
||||
)
|
||||
<|> subparser
|
||||
(command
|
||||
"nuke"
|
||||
(info (pure Nuke <**> helper)
|
||||
(progDesc "Completely remove ghcup from your system"))
|
||||
<> commandGroup "Nuclear Commands:"
|
||||
<> hidden
|
||||
)
|
||||
<|> subparser
|
||||
(command
|
||||
"print-app-errors"
|
||||
(info (pure PrintAppErrors <**> helper)
|
||||
(progDesc ""))
|
||||
<> internal
|
||||
)
|
||||
@@ -1,148 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.ChangeLog where
|
||||
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Errors
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.Prelude.Process (exec)
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import URI.ByteString (serializeURIRef')
|
||||
import Data.Char (toLower)
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data ChangeLogOptions = ChangeLogOptions
|
||||
{ clOpen :: Bool
|
||||
, clTool :: Maybe Tool
|
||||
, clToolVer :: Maybe ToolVersion
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
changelogP :: Parser ChangeLogOptions
|
||||
changelogP =
|
||||
(\x y -> ChangeLogOptions x y)
|
||||
<$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\s' -> case fmap toLower s' of
|
||||
"ghc" -> Right GHC
|
||||
"cabal" -> Right Cabal
|
||||
"ghcup" -> Right GHCup
|
||||
"stack" -> Right Stack
|
||||
"hls" -> Right HLS
|
||||
e -> Left e
|
||||
)
|
||||
)
|
||||
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup|stack>" <> help
|
||||
"Open changelog for given tool (default: ghc)"
|
||||
<> completer toolCompleter
|
||||
)
|
||||
)
|
||||
<*> optional (toolVersionTagArgument [] Nothing)
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
changeLogFooter :: String
|
||||
changeLogFooter = [s|Discussion:
|
||||
By default returns the URI of the ChangeLog of the latest GHC release.
|
||||
Pass '-o' to automatically open via xdg-open.|]
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
changelog :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> ChangeLogOptions
|
||||
-> (forall a . ReaderT AppState m a -> m a)
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
changelog ChangeLogOptions{..} runAppState runLogger = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
|
||||
let tool = fromMaybe GHC clTool
|
||||
ver' = fromMaybe
|
||||
(ToolTag Latest)
|
||||
clToolVer
|
||||
muri = getChangeLog dls tool ver'
|
||||
case muri of
|
||||
Nothing -> do
|
||||
runLogger
|
||||
(logWarn $
|
||||
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> T.pack (prettyShow ver')
|
||||
)
|
||||
pure ExitSuccess
|
||||
Just uri -> do
|
||||
pfreq <- runAppState getPlatformReq
|
||||
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
||||
cmd = case _rPlatform pfreq of
|
||||
Darwin -> "open"
|
||||
Linux _ -> "xdg-open"
|
||||
FreeBSD -> "xdg-open"
|
||||
Windows -> "start"
|
||||
|
||||
if clOpen
|
||||
then do
|
||||
runAppState $
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
Right _ -> pure ExitSuccess
|
||||
Left e -> logError (T.pack $ prettyHFError e)
|
||||
>> pure (ExitFailure 13)
|
||||
else liftIO $ putStrLn uri' >> pure ExitSuccess
|
||||
@@ -1,831 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module GHCup.OptParse.Common where
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.MegaParsec
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad.Identity (Identity(..))
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson
|
||||
#if MIN_VERSION_aeson(2,0,0)
|
||||
import qualified Data.Aeson.Key as KM
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
#else
|
||||
import qualified Data.HashMap.Strict as KM
|
||||
#endif
|
||||
import Data.ByteString.Lazy ( ByteString )
|
||||
import Data.Bifunctor
|
||||
import Data.Char
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix )
|
||||
import Data.Maybe
|
||||
import Data.Text ( Text )
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Time.Format ( parseTimeM, defaultTimeLocale )
|
||||
import Data.Versions hiding ( str )
|
||||
import Data.Void
|
||||
import qualified Data.Vector as V
|
||||
import GHC.IO.Exception
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import Safe
|
||||
import System.Process ( readProcess )
|
||||
import System.FilePath
|
||||
import Text.HTML.TagSoup hiding ( Tag )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified System.FilePath.Posix as FP
|
||||
import GHCup.Version
|
||||
import Control.Exception (evaluate)
|
||||
import qualified Cabal.Config as CC
|
||||
|
||||
|
||||
-------------
|
||||
--[ Types ]--
|
||||
-------------
|
||||
|
||||
|
||||
-- a superset of ToolVersion
|
||||
data SetToolVersion = SetGHCVersion GHCTargetVersion
|
||||
| SetToolVersion Version
|
||||
| SetToolTag Tag
|
||||
| SetToolDay Day
|
||||
| SetRecommended
|
||||
| SetNext
|
||||
deriving (Eq, Show)
|
||||
|
||||
prettyToolVer :: ToolVersion -> String
|
||||
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v'
|
||||
prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'
|
||||
prettyToolVer (ToolTag t) = show t
|
||||
prettyToolVer (ToolDay day) = show day
|
||||
|
||||
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
|
||||
toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'
|
||||
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
|
||||
toSetToolVer (Just (ToolTag t')) = SetToolTag t'
|
||||
toSetToolVer (Just (ToolDay d')) = SetToolDay d'
|
||||
toSetToolVer Nothing = SetRecommended
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Parser ]--
|
||||
--------------
|
||||
|
||||
|
||||
toolVersionTagArgument :: [ListCriteria] -> Maybe Tool -> Parser ToolVersion
|
||||
toolVersionTagArgument criteria tool =
|
||||
argument (eitherReader (parser tool))
|
||||
(metavar (mv tool)
|
||||
<> completer (tagCompleter (fromMaybe GHC tool) [])
|
||||
<> foldMap (completer . versionCompleter criteria) tool)
|
||||
where
|
||||
mv (Just GHC) = "GHC_VERSION|TAG|RELEASE_DATE"
|
||||
mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE"
|
||||
mv _ = "VERSION|TAG|RELEASE_DATE"
|
||||
|
||||
parser (Just GHC) = ghcVersionTagEither
|
||||
parser Nothing = ghcVersionTagEither
|
||||
parser _ = toolVersionTagEither
|
||||
|
||||
|
||||
versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version
|
||||
versionParser' criteria tool = argument
|
||||
(eitherReader (first show . version . T.pack))
|
||||
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
|
||||
|
||||
ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion
|
||||
ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)
|
||||
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
|
||||
|
||||
|
||||
-- https://github.com/pcapriotti/optparse-applicative/issues/148
|
||||
|
||||
-- | A switch that can be enabled using --foo and disabled using --no-foo.
|
||||
--
|
||||
-- The option modifier is applied to only the option that is *not* enabled
|
||||
-- by default. For example:
|
||||
--
|
||||
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
|
||||
--
|
||||
-- This example makes --recursive enabled by default, so
|
||||
-- the help is shown only for --no-recursive.
|
||||
invertableSwitch
|
||||
:: String -- ^ long option
|
||||
-> Maybe 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")
|
||||
-> Maybe Char -- ^ short option for the non-default option
|
||||
-> Bool -- ^ is switch enabled by default?
|
||||
-> Mod FlagFields Bool -- ^ option modifier for --foo
|
||||
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
|
||||
-> Parser (Maybe Bool)
|
||||
invertableSwitch' longopt shortopt defv enmod dismod = optional
|
||||
( flag' True ( enmod <> long longopt <> if defv then mempty else maybe mempty short shortopt)
|
||||
<|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty short shortopt else mempty)
|
||||
)
|
||||
where
|
||||
nolongopt = "no-" ++ longopt
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Either Parser ]--
|
||||
---------------------
|
||||
|
||||
|
||||
platformParser :: String -> Either String PlatformRequest
|
||||
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
Right r -> pure r
|
||||
Left e -> Left $ errorBundlePretty e
|
||||
where
|
||||
archP :: MP.Parsec Void Text Architecture
|
||||
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
|
||||
platformP :: MP.Parsec Void Text PlatformRequest
|
||||
platformP = choice'
|
||||
[ (`PlatformRequest` FreeBSD)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> ( MP.chunk "portbld"
|
||||
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
|
||||
<|> pure Nothing
|
||||
)
|
||||
<* MP.chunk "-freebsd"
|
||||
)
|
||||
, (`PlatformRequest` Darwin)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> ( MP.chunk "apple"
|
||||
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
|
||||
<|> pure Nothing
|
||||
)
|
||||
<* MP.chunk "-darwin"
|
||||
)
|
||||
, (\a d mv -> PlatformRequest a (Linux d) mv)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> distroP
|
||||
<*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
|
||||
)
|
||||
<* MP.chunk "-linux"
|
||||
)
|
||||
]
|
||||
distroP :: MP.Parsec Void Text LinuxDistro
|
||||
distroP = choice'
|
||||
[ MP.chunk "debian" $> Debian
|
||||
, MP.chunk "deb" $> Debian
|
||||
, MP.chunk "ubuntu" $> Ubuntu
|
||||
, MP.chunk "mint" $> Mint
|
||||
, MP.chunk "fedora" $> Fedora
|
||||
, MP.chunk "centos" $> CentOS
|
||||
, MP.chunk "redhat" $> RedHat
|
||||
, MP.chunk "alpine" $> Alpine
|
||||
, MP.chunk "gentoo" $> Gentoo
|
||||
, MP.chunk "exherbo" $> Exherbo
|
||||
, MP.chunk "unknown" $> UnknownLinux
|
||||
]
|
||||
|
||||
|
||||
uriParser :: String -> Either String URI
|
||||
uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString
|
||||
|
||||
|
||||
absolutePathParser :: FilePath -> Either String FilePath
|
||||
absolutePathParser f = case isValid f && isAbsolute f of
|
||||
True -> Right $ normalise f
|
||||
False -> Left "Please enter a valid absolute filepath."
|
||||
|
||||
isolateParser :: FilePath -> Either String FilePath
|
||||
isolateParser f = case isValid f && isAbsolute f of
|
||||
True -> Right $ normalise f
|
||||
False -> Left "Please enter a valid filepath for isolate dir."
|
||||
|
||||
-- this accepts cross prefix
|
||||
ghcVersionTagEither :: String -> Either String ToolVersion
|
||||
ghcVersionTagEither s' =
|
||||
second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')
|
||||
|
||||
-- this ignores cross prefix
|
||||
toolVersionTagEither :: String -> Either String ToolVersion
|
||||
toolVersionTagEither s' =
|
||||
second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')
|
||||
|
||||
tagEither :: String -> Either String Tag
|
||||
tagEither s' = case fmap toLower s' of
|
||||
"recommended" -> Right Recommended
|
||||
"latest" -> Right Latest
|
||||
"latest-prerelease" -> Right LatestPrerelease
|
||||
"latest-nightly" -> Right LatestNightly
|
||||
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
|
||||
Right x -> Right (Base x)
|
||||
Left _ -> Left $ "Invalid PVP version for base " <> ver'
|
||||
other -> Left $ "Unknown tag " <> other
|
||||
|
||||
|
||||
ghcVersionEither :: String -> Either String GHCTargetVersion
|
||||
ghcVersionEither =
|
||||
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
|
||||
|
||||
toolVersionEither :: String -> Either String Version
|
||||
toolVersionEither =
|
||||
first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack
|
||||
|
||||
|
||||
toolParser :: String -> Either String Tool
|
||||
toolParser s' | t == T.pack "ghc" = Right GHC
|
||||
| t == T.pack "cabal" = Right Cabal
|
||||
| t == T.pack "hls" = Right HLS
|
||||
| t == T.pack "stack" = Right Stack
|
||||
| otherwise = Left ("Unknown tool: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
dayParser :: String -> Either String Day
|
||||
dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right
|
||||
$ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s
|
||||
|
||||
|
||||
criteriaParser :: String -> Either String ListCriteria
|
||||
criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True
|
||||
| t == T.pack "set" = Right $ ListSet True
|
||||
| t == T.pack "available" = Right $ ListAvailable True
|
||||
| t == T.pack "+installed" = Right $ ListInstalled True
|
||||
| t == T.pack "+set" = Right $ ListSet True
|
||||
| t == T.pack "+available" = Right $ ListAvailable True
|
||||
| t == T.pack "-installed" = Right $ ListInstalled False
|
||||
| t == T.pack "-set" = Right $ ListSet False
|
||||
| t == T.pack "-available" = Right $ ListAvailable False
|
||||
| otherwise = Left ("Unknown criteria: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
|
||||
keepOnParser :: String -> Either String KeepDirs
|
||||
keepOnParser s' | t == T.pack "always" = Right Always
|
||||
| t == T.pack "errors" = Right Errors
|
||||
| t == T.pack "never" = Right Never
|
||||
| otherwise = Left ("Unknown keep value: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
downloaderParser :: String -> Either String Downloader
|
||||
downloaderParser s' | t == T.pack "curl" = Right Curl
|
||||
| t == T.pack "wget" = Right Wget
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
| t == T.pack "internal" = Right Internal
|
||||
#endif
|
||||
| otherwise = Left ("Unknown downloader value: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
gpgParser :: String -> Either String GPGSetting
|
||||
gpgParser s' | t == T.pack "strict" = Right GPGStrict
|
||||
| t == T.pack "lax" = Right GPGLax
|
||||
| t == T.pack "none" = Right GPGNone
|
||||
| otherwise = Left ("Unknown gpg setting value: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Completers ]--
|
||||
------------------
|
||||
|
||||
|
||||
toolCompleter :: Completer
|
||||
toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
|
||||
|
||||
gitFileUri :: [String] -> Completer
|
||||
gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
|
||||
|
||||
fileUri :: Completer
|
||||
fileUri = mkCompleter $ fileUri' []
|
||||
|
||||
fileUri' :: [String] -> String -> IO [String]
|
||||
fileUri' add = \case
|
||||
"" -> do
|
||||
pwd <- getCurrentDirectory
|
||||
pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add
|
||||
xs
|
||||
| "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$>
|
||||
case stripPrefix "file://" xs of
|
||||
Nothing -> pure []
|
||||
Just r -> do
|
||||
pwd <- getCurrentDirectory
|
||||
dirs <- compgen "directory" r ["-S", "/"]
|
||||
files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r []
|
||||
pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else [])
|
||||
| xs `isPrefixOf` "file:///" -> pure ["file:///"]
|
||||
| xs `isPrefixOf` "https://" -> pure ["https://"]
|
||||
| xs `isPrefixOf` "http://" -> pure ["http://"]
|
||||
| otherwise -> pure []
|
||||
where
|
||||
compgen :: String -> String -> [String] -> IO [String]
|
||||
compgen action' r opts = do
|
||||
let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r]
|
||||
result <- tryIO $ readProcess "bash" ["-c", cmd] ""
|
||||
return . lines . either (const []) id $ result
|
||||
|
||||
-- | Strongly quote the string we pass to compgen.
|
||||
--
|
||||
-- We need to do this so bash doesn't expand out any ~ or other
|
||||
-- chars we want to complete on, or emit an end of line error
|
||||
-- when seeking the close to the quote.
|
||||
--
|
||||
-- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote
|
||||
requote :: String -> String
|
||||
requote s =
|
||||
let
|
||||
-- Bash doesn't appear to allow "mixed" escaping
|
||||
-- in bash completions. So we don't have to really
|
||||
-- worry about people swapping between strong and
|
||||
-- weak quotes.
|
||||
unescaped =
|
||||
case s of
|
||||
-- It's already strongly quoted, so we
|
||||
-- can use it mostly as is, but we must
|
||||
-- ensure it's closed off at the end and
|
||||
-- there's no single quotes in the
|
||||
-- middle which might confuse bash.
|
||||
('\'': rs) -> unescapeN rs
|
||||
|
||||
-- We're weakly quoted.
|
||||
('"': rs) -> unescapeD rs
|
||||
|
||||
-- We're not quoted at all.
|
||||
-- We need to unescape some characters like
|
||||
-- spaces and quotation marks.
|
||||
elsewise -> unescapeU elsewise
|
||||
in
|
||||
strong unescaped
|
||||
|
||||
where
|
||||
strong ss = '\'' : foldr go "'" ss
|
||||
where
|
||||
-- If there's a single quote inside the
|
||||
-- command: exit from the strong quote and
|
||||
-- emit it the quote escaped, then resume.
|
||||
go '\'' t = "'\\''" ++ t
|
||||
go h t = h : t
|
||||
|
||||
-- Unescape a strongly quoted string
|
||||
-- We have two recursive functions, as we
|
||||
-- can enter and exit the strong escaping.
|
||||
unescapeN = goX
|
||||
where
|
||||
goX ('\'' : xs) = goN xs
|
||||
goX (x : xs) = x : goX xs
|
||||
goX [] = []
|
||||
|
||||
goN ('\\' : '\'' : xs) = '\'' : goN xs
|
||||
goN ('\'' : xs) = goX xs
|
||||
goN (x : xs) = x : goN xs
|
||||
goN [] = []
|
||||
|
||||
-- Unescape an unquoted string
|
||||
unescapeU = goX
|
||||
where
|
||||
goX [] = []
|
||||
goX ('\\' : x : xs) = x : goX xs
|
||||
goX (x : xs) = x : goX xs
|
||||
|
||||
-- Unescape a weakly quoted string
|
||||
unescapeD = goX
|
||||
where
|
||||
-- Reached an escape character
|
||||
goX ('\\' : x : xs)
|
||||
-- If it's true escapable, strip the
|
||||
-- slashes, as we're going to strong
|
||||
-- escape instead.
|
||||
| x `elem` ("$`\"\\\n" :: String) = x : goX xs
|
||||
| otherwise = '\\' : x : goX xs
|
||||
-- We've ended quoted section, so we
|
||||
-- don't recurse on goX, it's done.
|
||||
goX ('"' : xs)
|
||||
= xs
|
||||
-- Not done, but not a special character
|
||||
-- just continue the fold.
|
||||
goX (x : xs)
|
||||
= x : goX xs
|
||||
goX []
|
||||
= []
|
||||
|
||||
|
||||
tagCompleter :: Tool -> [String] -> Completer
|
||||
tagCompleter tool add = listIOCompleter $ do
|
||||
dirs' <- liftIO getAllDirs
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = False
|
||||
, consoleOutter = mempty
|
||||
, fileOutter = mempty
|
||||
, fancyColors = False
|
||||
}
|
||||
let appState = LeanAppState
|
||||
(defaultSettings { noNetwork = True })
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
loggerConfig
|
||||
|
||||
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
|
||||
case mGhcUpInfo of
|
||||
VRight ghcupInfo -> do
|
||||
let allTags = filter (/= Old)
|
||||
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
|
||||
pure $ nub $ (add ++) $ fmap tagToString allTags
|
||||
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
|
||||
|
||||
versionCompleter :: [ListCriteria] -> Tool -> Completer
|
||||
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
|
||||
|
||||
versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer
|
||||
versionCompleter' criteria tool filter' = listIOCompleter $ do
|
||||
dirs' <- liftIO getAllDirs
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = False
|
||||
, consoleOutter = mempty
|
||||
, fileOutter = mempty
|
||||
, fancyColors = False
|
||||
}
|
||||
let settings = defaultSettings { noNetwork = True }
|
||||
let leanAppState = LeanAppState
|
||||
settings
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
loggerConfig
|
||||
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
|
||||
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
|
||||
forFold mpFreq $ \pfreq -> do
|
||||
forFold mGhcUpInfo $ \ghcupInfo -> do
|
||||
let appState = AppState
|
||||
settings
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
ghcupInfo
|
||||
pfreq
|
||||
loggerConfig
|
||||
|
||||
runEnv = flip runReaderT appState
|
||||
|
||||
installedVersions <- runEnv $ listVersions (Just tool) criteria False False (Nothing, Nothing)
|
||||
return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions
|
||||
|
||||
|
||||
toolDlCompleter :: Tool -> Completer
|
||||
toolDlCompleter tool = mkCompleter $ \case
|
||||
"" -> pure (initUrl tool <> ["https://", "http://", "file:///"])
|
||||
word
|
||||
| "file://" `isPrefixOf` word -> fileUri' [] word
|
||||
-- downloads.haskell.org
|
||||
| "https://downloads.haskell.org/" `isPrefixOf` word ->
|
||||
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word
|
||||
|
||||
-- github releases
|
||||
| "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
|
||||
, let xs = splitPath word
|
||||
, (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
|
||||
fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server"
|
||||
| "https://github.com/commercialhaskell/stack/releases/download/" == word
|
||||
, let xs = splitPath word
|
||||
, (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
|
||||
fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack"
|
||||
|
||||
-- github release assets
|
||||
| "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
|
||||
, let xs = splitPath word
|
||||
, (length xs == 7 && last word == '/') || length xs == 8
|
||||
, let rel = xs !! 6
|
||||
, length rel > 1 -> do
|
||||
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel)
|
||||
| "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word
|
||||
, let xs = splitPath word
|
||||
, (length xs == 7 && last word == '/') || length xs == 8
|
||||
, let rel = xs !! 6
|
||||
, length rel > 1 -> do
|
||||
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel)
|
||||
|
||||
-- github
|
||||
| "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
|
||||
| "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
|
||||
| "https://g" `isPrefixOf` word
|
||||
, tool == Stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
|
||||
| "https://g" `isPrefixOf` word
|
||||
, tool == HLS -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
|
||||
|
||||
| "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool
|
||||
|
||||
| "h" `isPrefixOf` word -> pure $ initUrl tool
|
||||
|
||||
| word `isPrefixOf` "file:///" -> pure ["file:///"]
|
||||
| word `isPrefixOf` "https://" -> pure ["https://"]
|
||||
| word `isPrefixOf` "http://" -> pure ["http://"]
|
||||
|
||||
| otherwise -> pure []
|
||||
where
|
||||
initUrl :: Tool -> [String]
|
||||
initUrl GHC = [ "https://downloads.haskell.org/~ghc/"
|
||||
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/"
|
||||
]
|
||||
initUrl Cabal = [ "https://downloads.haskell.org/~cabal/"
|
||||
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/"
|
||||
]
|
||||
initUrl GHCup = [ "https://downloads.haskell.org/~ghcup/" ]
|
||||
initUrl HLS = [ "https://github.com/haskell/haskell-language-server/releases/download/"
|
||||
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/"
|
||||
]
|
||||
initUrl Stack = [ "https://github.com/commercialhaskell/stack/releases/download/"
|
||||
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/"
|
||||
]
|
||||
|
||||
completePrefix :: String -- ^ url, e.g. 'https://github.com/haskell/haskell-languag'
|
||||
-> String -- ^ match, e.g. 'haskell-language-server'
|
||||
-> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server'
|
||||
completePrefix url match =
|
||||
let base = FP.takeDirectory url
|
||||
fn = FP.takeFileName url
|
||||
in if fn `isPrefixOf` match then base <> "/" <> match else url
|
||||
|
||||
prefixMatch :: String -> [String] -> [String]
|
||||
prefixMatch pref = filter (pref `isPrefixOf`)
|
||||
|
||||
fromHRef :: String -> IO [String]
|
||||
fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout ->
|
||||
pure
|
||||
. fmap (T.unpack . decUTF8Safe' . fromAttrib "href")
|
||||
. filter isTagOpen
|
||||
. filter (~== ("<a href>" :: String))
|
||||
. parseTags
|
||||
$ stdout
|
||||
|
||||
withCurl :: String -- ^ url
|
||||
-> Int -- ^ delay
|
||||
-> (ByteString -> IO [String]) -- ^ callback
|
||||
-> IO [String]
|
||||
withCurl url delay cb = do
|
||||
let limit = threadDelay delay
|
||||
race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case
|
||||
Right (CapturedProcess {_exitCode, _stdOut}) -> do
|
||||
case _exitCode of
|
||||
ExitSuccess ->
|
||||
(try @_ @SomeException . cb $ _stdOut) >>= \case
|
||||
Left _ -> pure []
|
||||
Right r' -> do
|
||||
r <- try @_ @SomeException
|
||||
. evaluate
|
||||
. force
|
||||
$ r'
|
||||
either (\_ -> pure []) pure r
|
||||
ExitFailure _ -> pure []
|
||||
Left _ -> pure []
|
||||
|
||||
getGithubReleases :: String
|
||||
-> String
|
||||
-> IO [String]
|
||||
getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do
|
||||
Just xs <- pure $ decode' @Array stdout
|
||||
fmap V.toList $ forM xs $ \x -> do
|
||||
(Object r) <- pure x
|
||||
Just (String name) <- pure $ KM.lookup (mkval "tag_name") r
|
||||
pure $ T.unpack name
|
||||
where
|
||||
url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases"
|
||||
|
||||
getGithubAssets :: String
|
||||
-> String
|
||||
-> String
|
||||
-> IO [String]
|
||||
getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do
|
||||
Just xs <- pure $ decode' @Object stdout
|
||||
Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs
|
||||
as <- fmap V.toList $ forM assets $ \val -> do
|
||||
(Object asset) <- pure val
|
||||
Just (String name) <- pure $ KM.lookup (mkval "name") asset
|
||||
pure $ T.unpack name
|
||||
pure as
|
||||
where
|
||||
url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag
|
||||
|
||||
|
||||
#if MIN_VERSION_aeson(2,0,0)
|
||||
mkval = KM.fromString
|
||||
#else
|
||||
mkval = id
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
-----------------
|
||||
|
||||
|
||||
fromVersion :: ( HasLog env
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion tv = fromVersion' (toSetToolVer tv)
|
||||
|
||||
fromVersion' :: ( HasLog env
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> SetToolVersion
|
||||
-> Tool
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion' SetRecommended tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
second Just <$> getRecommended dls tool
|
||||
?? TagNotFound Recommended tool
|
||||
fromVersion' (SetGHCVersion v) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo v tool dls
|
||||
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
|
||||
Left _ -> pure (v, vi)
|
||||
Right pvpIn ->
|
||||
lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
|
||||
Just (pvp_, vi', mt) -> do
|
||||
v' <- lift $ pvpToVersion pvp_ ""
|
||||
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
|
||||
pure (GHCTargetVersion mt v', Just vi')
|
||||
Nothing -> pure (v, vi)
|
||||
fromVersion' (SetToolVersion (mkTVer -> v)) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo v tool dls
|
||||
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
|
||||
Left _ -> pure (v, vi)
|
||||
Right pvpIn ->
|
||||
lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
|
||||
Just (pvp_, vi', mt) -> do
|
||||
v' <- lift $ pvpToVersion pvp_ ""
|
||||
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
|
||||
pure (GHCTargetVersion mt v', Just vi')
|
||||
Nothing -> pure (v, vi)
|
||||
fromVersion' (SetToolTag Latest) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool
|
||||
fromVersion' (SetToolDay day) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap id Just <$> case getByReleaseDay dls tool day of
|
||||
Left ad -> throwE $ DayNotFound day tool ad
|
||||
Right v -> pure v
|
||||
fromVersion' (SetToolTag LatestPrerelease) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool
|
||||
fromVersion' (SetToolTag LatestNightly) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool
|
||||
fromVersion' (SetToolTag Recommended) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolTag (Base pvp'')) GHC = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
|
||||
fromVersion' SetNext tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
next <- case tool of
|
||||
GHC -> do
|
||||
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
|
||||
ghcs <- rights <$> lift getInstalledGHCs
|
||||
(headMay
|
||||
. tail
|
||||
. dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
|
||||
. cycle
|
||||
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
|
||||
. filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
|
||||
$ ghcs) ?? NoToolVersionSet tool
|
||||
Cabal -> do
|
||||
set <- cabalSet !? NoToolVersionSet tool
|
||||
cabals <- rights <$> lift getInstalledCabals
|
||||
(fmap (GHCTargetVersion Nothing)
|
||||
. headMay
|
||||
. tail
|
||||
. dropWhile (/= set)
|
||||
. cycle
|
||||
. sort
|
||||
$ cabals) ?? NoToolVersionSet tool
|
||||
HLS -> do
|
||||
set <- hlsSet !? NoToolVersionSet tool
|
||||
hlses <- rights <$> lift getInstalledHLSs
|
||||
(fmap (GHCTargetVersion Nothing)
|
||||
. headMay
|
||||
. tail
|
||||
. dropWhile (/= set)
|
||||
. cycle
|
||||
. sort
|
||||
$ hlses) ?? NoToolVersionSet tool
|
||||
Stack -> do
|
||||
set <- stackSet !? NoToolVersionSet tool
|
||||
stacks <- rights <$> lift getInstalledStacks
|
||||
(fmap (GHCTargetVersion Nothing)
|
||||
. headMay
|
||||
. tail
|
||||
. dropWhile (/= set)
|
||||
. cycle
|
||||
. sort
|
||||
$ stacks) ?? NoToolVersionSet tool
|
||||
GHCup -> fail "GHCup cannot be set"
|
||||
let vi = getVersionInfo next tool dls
|
||||
pure (next, vi)
|
||||
fromVersion' (SetToolTag t') tool =
|
||||
throwE $ TagNotFound t' tool
|
||||
|
||||
|
||||
checkForUpdates :: ( MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> m [(Tool, GHCTargetVersion)]
|
||||
checkForUpdates = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
||||
lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)
|
||||
let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
|
||||
|
||||
ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do
|
||||
(Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
|
||||
if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing
|
||||
|
||||
otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
|
||||
forMM (getLatest dls t) $ \(l, _) -> do
|
||||
let mver = latestInstalled t
|
||||
forMM mver $ \ver ->
|
||||
if (l > ver) then pure $ Just (t, l) else pure Nothing
|
||||
|
||||
pure $ catMaybes (ghcup:otherTools)
|
||||
where
|
||||
forMM a f = fmap join $ forM a f
|
||||
|
||||
|
||||
logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m ()
|
||||
logGHCPostRm ghcVer = do
|
||||
cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store")
|
||||
(runIdentity . CC.cfgStoreDir <$> CC.readConfig)
|
||||
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
|
||||
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir
|
||||
|
||||
@@ -1,621 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Compile where
|
||||
|
||||
|
||||
import GHCup
|
||||
import qualified GHCup.GHC as GHC
|
||||
import qualified GHCup.HLS as HLS
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Codec.Archive ( ArchiveResult )
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Bifunctor
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.Versions ( Version, prettyVer, version, pvp )
|
||||
import qualified Data.Versions as V
|
||||
import Data.Text ( Text )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import URI.ByteString hiding ( uriParser )
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask, displayException)
|
||||
import System.FilePath (isPathSeparator)
|
||||
import Text.Read (readEither)
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data CompileCommand = CompileGHC GHCCompileOptions
|
||||
| CompileHLS HLSCompileOptions
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data GHCCompileOptions = GHCCompileOptions
|
||||
{ targetGhc :: GHC.GHCVer
|
||||
, bootstrapGhc :: Either Version FilePath
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe FilePath
|
||||
, patches :: Maybe (Either FilePath [URI])
|
||||
, crossTarget :: Maybe Text
|
||||
, addConfArgs :: [Text]
|
||||
, setCompile :: Bool
|
||||
, ovewrwiteVer :: Maybe Version
|
||||
, buildFlavour :: Maybe String
|
||||
, buildSystem :: Maybe BuildSystem
|
||||
, isolateDir :: Maybe FilePath
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
data HLSCompileOptions = HLSCompileOptions
|
||||
{ targetHLS :: HLS.HLSVer
|
||||
, jobs :: Maybe Int
|
||||
, setCompile :: Bool
|
||||
, updateCabal :: Bool
|
||||
, ovewrwiteVer :: Either Bool Version
|
||||
, isolateDir :: Maybe FilePath
|
||||
, cabalProject :: Maybe (Either FilePath URI)
|
||||
, cabalProjectLocal :: Maybe URI
|
||||
, patches :: Maybe (Either FilePath [URI])
|
||||
, targetGHCs :: [ToolVersion]
|
||||
, cabalArgs :: [Text]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
compileP :: Parser CompileCommand
|
||||
compileP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
( CompileGHC
|
||||
<$> info
|
||||
(ghcCompileOpts <**> helper)
|
||||
( progDesc "Compile GHC from source"
|
||||
<> footerDoc (Just $ text compileFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( CompileHLS
|
||||
<$> info
|
||||
(hlsCompileOpts <**> helper)
|
||||
( progDesc "Compile HLS from source"
|
||||
<> footerDoc (Just $ text compileHLSFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
where
|
||||
compileFooter = [s|Discussion:
|
||||
Compiles and installs the specified GHC version into
|
||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||
|
||||
This also allows building a cross-compiler. Consult the documentation
|
||||
first: <https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#configuring-the-build>
|
||||
|
||||
ENV variables:
|
||||
Various toolchain variables will be passed onto the ghc build system,
|
||||
such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
|
||||
|
||||
Examples:
|
||||
# compile from known version
|
||||
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
|
||||
# compile from git commit/reference
|
||||
ghcup compile ghc -j 4 -g master -b 8.2.2
|
||||
# specify path to bootstrap ghc
|
||||
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
|
||||
# build cross compiler
|
||||
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
|
||||
|
||||
compileHLSFooter = [s|Discussion:
|
||||
Compiles and installs the specified HLS version.
|
||||
The --ghc arguments are necessary to specify which GHC version to build for/against.
|
||||
These need to be available in PATH prior to compilation.
|
||||
|
||||
Examples:
|
||||
# compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build
|
||||
ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update
|
||||
# compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state
|
||||
ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')
|
||||
# compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name
|
||||
ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]
|
||||
|
||||
|
||||
ghcCompileOpts :: Parser GHCCompileOptions
|
||||
ghcCompileOpts =
|
||||
GHCCompileOptions
|
||||
<$> ((GHC.SourceDist <$> option
|
||||
(eitherReader
|
||||
(first (const "Not a valid version") . version . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The tool version to compile"
|
||||
<> (completer $ versionCompleter [] GHC)
|
||||
)
|
||||
) <|>
|
||||
(GHC.GitDist <$> (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)"
|
||||
<> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])
|
||||
))
|
||||
))
|
||||
<|>
|
||||
(
|
||||
GHC.RemoteDist <$> (option
|
||||
(eitherReader uriParser)
|
||||
(long "remote-source-dist" <> metavar "URI" <> help
|
||||
"URI (https/http/file) to a GHC source distribution"
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
|
||||
)
|
||||
)
|
||||
( short 'b'
|
||||
<> long "bootstrap-ghc"
|
||||
<> metavar "BOOTSTRAP_GHC"
|
||||
<> help
|
||||
"The GHC version (or full path) to bootstrap with (must be installed)"
|
||||
<> (completer $ versionCompleter [] GHC)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader (readEither @Int))
|
||||
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
|
||||
"How many jobs to use for make"
|
||||
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
str
|
||||
(short 'c' <> long "config" <> metavar "CONFIG" <> help
|
||||
"Absolute path to build config file"
|
||||
<> completer (bashCompleter "file")
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
(
|
||||
(fmap Right $ many $ option
|
||||
(eitherReader uriParser)
|
||||
(long "patch" <> metavar "PATCH_URI" <> help
|
||||
"URI to a patch (https/http/file)"
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
<|>
|
||||
(fmap Left $ option
|
||||
str
|
||||
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
|
||||
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)"
|
||||
<> completer (bashCompleter "directory")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> 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 compile configure, prefix with '-- ' (longopts)"))
|
||||
<*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(first (const "Not a valid version") . version . T.pack)
|
||||
)
|
||||
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
|
||||
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
|
||||
<> (completer $ versionCompleter [] GHC)
|
||||
)
|
||||
)
|
||||
<*> 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')"
|
||||
)
|
||||
)
|
||||
<*> (
|
||||
(\b -> if b then Just Hadrian else Nothing) <$> switch
|
||||
(long "hadrian" <> help "Use the hadrian build system instead of make. Tries to detect by default."
|
||||
)
|
||||
<|>
|
||||
(\b -> if b then Just Make else Nothing) <$> switch
|
||||
(long "make" <> help "Use the make build system instead of hadrian. Tries to detect by default."
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader isolateParser)
|
||||
( short 'i'
|
||||
<> long "isolate"
|
||||
<> metavar "DIR"
|
||||
<> help "install in an isolated absolute directory instead of the default one, no symlinks to this installation will be made"
|
||||
<> completer (bashCompleter "directory")
|
||||
)
|
||||
)
|
||||
|
||||
hlsCompileOpts :: Parser HLSCompileOptions
|
||||
hlsCompileOpts =
|
||||
HLSCompileOptions
|
||||
<$> ((HLS.HackageDist <$> option
|
||||
(eitherReader
|
||||
((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The version to compile (pulled from hackage)"
|
||||
<> (completer $ versionCompleter' [] HLS (either (const False) (const True) . V.pvp . V.prettyVer))
|
||||
)
|
||||
)
|
||||
<|>
|
||||
(HLS.GitDist <$> (GitBranch <$> option
|
||||
str
|
||||
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
|
||||
"The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
|
||||
) <*>
|
||||
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
|
||||
<> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
|
||||
))
|
||||
))
|
||||
<|>
|
||||
(HLS.SourceDist <$> (option
|
||||
(eitherReader
|
||||
(first (const "Not a valid version") . version . T.pack)
|
||||
)
|
||||
(long "source-dist" <> metavar "VERSION" <> help
|
||||
"The version to compile (pulled from packaged git sources)"
|
||||
<> (completer $ versionCompleter [] HLS)
|
||||
)
|
||||
))
|
||||
<|>
|
||||
(
|
||||
HLS.RemoteDist <$> (option
|
||||
(eitherReader uriParser)
|
||||
(long "remote-source-dist" <> metavar "URI" <> help
|
||||
"URI (https/http/file) to a HLS source distribution"
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader (readEither @Int))
|
||||
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
|
||||
"How many jobs to use for make"
|
||||
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
|
||||
)
|
||||
)
|
||||
<*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
|
||||
<*> switch (long "cabal-update" <> help "Run 'cabal update' before the build")
|
||||
<*>
|
||||
(
|
||||
(Right <$> 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'"
|
||||
<> (completer $ versionCompleter [] HLS)
|
||||
)
|
||||
)
|
||||
<|>
|
||||
(Left <$> (switch
|
||||
(long "git-describe-version"
|
||||
<> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader isolateParser)
|
||||
( short 'i'
|
||||
<> long "isolate"
|
||||
<> metavar "DIR"
|
||||
<> help "install in an isolated absolute directory instead of the default one, no symlinks to this installation will be made"
|
||||
<> completer (bashCompleter "directory")
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
|
||||
(long "cabal-project" <> metavar "CABAL_PROJECT" <> help
|
||||
"If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader uriParser)
|
||||
(long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
|
||||
"URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
(
|
||||
(fmap Right $ many $ option
|
||||
(eitherReader uriParser)
|
||||
(long "patch" <> metavar "PATCH_URI" <> help
|
||||
"URI to a patch (https/http/file)"
|
||||
<> completer fileUri
|
||||
)
|
||||
)
|
||||
<|>
|
||||
(fmap Left $ option
|
||||
str
|
||||
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
|
||||
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
|
||||
<> completer (bashCompleter "directory")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> some (
|
||||
option (eitherReader ghcVersionTagEither)
|
||||
( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
|
||||
<> completer (tagCompleter GHC [])
|
||||
<> completer (versionCompleter [] GHC))
|
||||
)
|
||||
<*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type GHCEffects = '[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoDownload
|
||||
, NotFoundInPATH
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, NotInstalled
|
||||
, DirNotEmpty
|
||||
, ArchiveResult
|
||||
, FileDoesNotExistError
|
||||
, HadrianNotFound
|
||||
, InvalidBuildConfig
|
||||
, ProcessError
|
||||
, CopyError
|
||||
, BuildFailed
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
]
|
||||
type HLSEffects = '[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoDownload
|
||||
, NotFoundInPATH
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, NotInstalled
|
||||
, DirNotEmpty
|
||||
, ArchiveResult
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
]
|
||||
|
||||
|
||||
|
||||
runCompileGHC :: (MonadUnliftIO m, MonadIO m)
|
||||
=> (ReaderT AppState m (VEither GHCEffects a) -> m (VEither GHCEffects a))
|
||||
-> Excepts GHCEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither GHCEffects a)
|
||||
runCompileGHC runAppState =
|
||||
runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@GHCEffects
|
||||
|
||||
runCompileHLS :: (MonadUnliftIO m, MonadIO m)
|
||||
=> (ReaderT AppState m (VEither HLSEffects a) -> m (VEither HLSEffects a))
|
||||
-> Excepts HLSEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither HLSEffects a)
|
||||
runCompileHLS runAppState =
|
||||
runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@HLSEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
compile :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> CompileCommand
|
||||
-> Settings
|
||||
-> Dirs
|
||||
-> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
compile compileCommand settings Dirs{..} runAppState runLogger = do
|
||||
case compileCommand of
|
||||
(CompileHLS HLSCompileOptions { .. }) -> do
|
||||
runCompileHLS runAppState (do
|
||||
case targetHLS of
|
||||
HLS.SourceDist targetVer -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (mkTVer targetVer) HLS dls
|
||||
forM_ (_viPreCompile =<< vi) $ \msg -> do
|
||||
lift $ logInfo msg
|
||||
lift $ logInfo
|
||||
"...waiting for 5 seconds, you can still abort..."
|
||||
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
|
||||
_ -> pure ()
|
||||
ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
|
||||
targetVer <- liftE $ compileHLS
|
||||
targetHLS
|
||||
ghcs
|
||||
jobs
|
||||
ovewrwiteVer
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
cabalProject
|
||||
cabalProjectLocal
|
||||
updateCabal
|
||||
patches
|
||||
cabalArgs
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (mkTVer targetVer) HLS dls
|
||||
when setCompile $ void $ liftE $
|
||||
setHLS targetVer SetHLSOnly Nothing
|
||||
pure (vi, targetVer)
|
||||
)
|
||||
>>= \case
|
||||
VRight (vi, tv) -> do
|
||||
runLogger $ logInfo
|
||||
"HLS successfully compiled and installed"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
liftIO $ putStr (T.unpack $ prettyVer tv)
|
||||
pure ExitSuccess
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger $ logError $ T.pack $ prettyHFError err
|
||||
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
|
||||
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
|
||||
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
pure $ ExitFailure 9
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 9
|
||||
(CompileGHC GHCCompileOptions {..}) ->
|
||||
runCompileGHC runAppState (do
|
||||
case targetGhc of
|
||||
GHC.SourceDist targetVer -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (mkTVer 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
|
||||
_ -> pure ()
|
||||
targetVer <- liftE $ compileGHC
|
||||
targetGhc
|
||||
crossTarget
|
||||
ovewrwiteVer
|
||||
bootstrapGhc
|
||||
jobs
|
||||
buildConfig
|
||||
patches
|
||||
addConfArgs
|
||||
buildFlavour
|
||||
buildSystem
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo targetVer GHC dls
|
||||
when setCompile $ void $ liftE $
|
||||
setGHC targetVer SetGHCOnly Nothing
|
||||
pure (vi, targetVer)
|
||||
)
|
||||
>>= \case
|
||||
VRight (vi, tv) -> do
|
||||
runLogger $ logInfo
|
||||
"GHC successfully compiled and installed"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
liftIO $ putStr (T.unpack $ tVerToText tv)
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ logWarn $
|
||||
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
|
||||
pure ExitSuccess
|
||||
VLeft (V (DirNotEmpty fp)) -> do
|
||||
runLogger $ logError $
|
||||
"Install directory " <> T.pack fp <> " is not empty."
|
||||
pure $ ExitFailure 3
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger $ logError $ T.pack $ prettyHFError err
|
||||
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
|
||||
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
|
||||
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
pure $ ExitFailure 9
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 9
|
||||
@@ -1,262 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Config where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Exception ( displayException )
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style, ParseError )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import URI.ByteString hiding ( uriParser )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.Yaml.Aeson as Y
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data ConfigCommand
|
||||
= ShowConfig
|
||||
| SetConfig String (Maybe String)
|
||||
| InitConfig
|
||||
| AddReleaseChannel Bool URI
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
configP :: Parser ConfigCommand
|
||||
configP = subparser
|
||||
( command "init" initP
|
||||
<> command "set" setP -- [set] KEY VALUE at help lhs
|
||||
<> command "show" showP
|
||||
<> command "add-release-channel" addP
|
||||
)
|
||||
<|> argsP -- add show for a single option
|
||||
<|> pure ShowConfig
|
||||
where
|
||||
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
|
||||
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
|
||||
setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
|
||||
argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
|
||||
addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
|
||||
(progDesc "Add a release channel from a URI")
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
configFooter :: String
|
||||
configFooter = [s|Examples:
|
||||
|
||||
# show current config
|
||||
ghcup config
|
||||
|
||||
# initialize config
|
||||
ghcup config init
|
||||
|
||||
# set <key> <value> configuration pair
|
||||
ghcup config set <key> <value>|]
|
||||
|
||||
|
||||
configSetFooter :: String
|
||||
configSetFooter = [s|Examples:
|
||||
# disable caching
|
||||
ghcup config set cache false
|
||||
|
||||
# switch downloader to wget
|
||||
ghcup config set downloader Wget
|
||||
|
||||
# set mirror for ghcup metadata
|
||||
ghcup config set '{url-source: { OwnSource: "<url>"}}'|]
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
-----------------
|
||||
|
||||
|
||||
formatConfig :: UserSettings -> String
|
||||
formatConfig = UTF8.toString . Y.encode
|
||||
|
||||
|
||||
updateSettings :: UserSettings -> UserSettings -> UserSettings
|
||||
updateSettings usl usr =
|
||||
let cache' = uCache usl <|> uCache usr
|
||||
metaCache' = uMetaCache usl <|> uMetaCache usr
|
||||
metaMode' = uMetaMode usl <|> uMetaMode usr
|
||||
noVerify' = uNoVerify usl <|> uNoVerify usr
|
||||
verbose' = uVerbose usl <|> uVerbose usr
|
||||
keepDirs' = uKeepDirs usl <|> uKeepDirs usr
|
||||
downloader' = uDownloader usl <|> uDownloader usr
|
||||
urlSource' = uUrlSource usl <|> uUrlSource usr
|
||||
noNetwork' = uNoNetwork usl <|> uNoNetwork usr
|
||||
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
|
||||
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
|
||||
mirrors' = uMirrors usl <|> uMirrors usr
|
||||
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
|
||||
where
|
||||
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
|
||||
updateKeyBindings Nothing Nothing = Nothing
|
||||
updateKeyBindings (Just kbl) Nothing = Just kbl
|
||||
updateKeyBindings Nothing (Just kbr) = Just kbr
|
||||
updateKeyBindings (Just kbl) (Just kbr) =
|
||||
Just $ UserKeyBindings {
|
||||
kUp = kUp kbl <|> kUp kbr
|
||||
, kDown = kDown kbl <|> kDown kbr
|
||||
, kQuit = kQuit kbl <|> kQuit kbr
|
||||
, kInstall = kInstall kbl <|> kInstall kbr
|
||||
, kUninstall = kUninstall kbl <|> kUninstall kbr
|
||||
, kSet = kSet kbl <|> kSet kbr
|
||||
, kChangelog = kChangelog kbl <|> kChangelog kbr
|
||||
, kShowAll = kShowAll kbl <|> kShowAll kbr
|
||||
, kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr
|
||||
}
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
data Duplicate = Duplicate -- ^ there is a duplicate somewhere in the middle
|
||||
| NoDuplicate -- ^ there is no duplicate
|
||||
| DuplicateLast -- ^ there's a duplicate, but it's the last element
|
||||
|
||||
|
||||
config :: forall m. ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> ConfigCommand
|
||||
-> Settings
|
||||
-> UserSettings
|
||||
-> KeyBindings
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
config configCommand settings userConf keybindings runLogger = case configCommand of
|
||||
InitConfig -> do
|
||||
path <- getConfigFilePath
|
||||
liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
|
||||
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
|
||||
pure ExitSuccess
|
||||
|
||||
ShowConfig -> do
|
||||
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
|
||||
pure ExitSuccess
|
||||
|
||||
(SetConfig k mv) -> do
|
||||
r <- runE @'[JSONError, ParseError] $ do
|
||||
case mv of
|
||||
Just "" ->
|
||||
throwE $ ParseError "Empty values are not allowed"
|
||||
Nothing -> do
|
||||
usersettings <- decodeSettings k
|
||||
lift $ doConfig usersettings
|
||||
pure ()
|
||||
Just v -> do
|
||||
usersettings <- decodeSettings (k <> ": " <> v <> "\n")
|
||||
lift $ doConfig usersettings
|
||||
pure ()
|
||||
case r of
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft (V (JSONDecodeError e)) -> do
|
||||
runLogger $ logError $ "Error decoding config: " <> T.pack e
|
||||
pure $ ExitFailure 65
|
||||
VLeft _ -> pure $ ExitFailure 65
|
||||
|
||||
AddReleaseChannel force uri -> do
|
||||
r <- runE @'[DuplicateReleaseChannel] $ do
|
||||
case urlSource settings of
|
||||
AddSource xs -> do
|
||||
case checkDuplicate xs (Right uri) of
|
||||
Duplicate
|
||||
| not force -> throwE (DuplicateReleaseChannel uri)
|
||||
DuplicateLast -> pure ()
|
||||
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
|
||||
GHCupURL -> do
|
||||
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
|
||||
pure ()
|
||||
OwnSource xs -> do
|
||||
case checkDuplicate xs (Right uri) of
|
||||
Duplicate
|
||||
| not force -> throwE (DuplicateReleaseChannel uri)
|
||||
DuplicateLast -> pure ()
|
||||
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
|
||||
OwnSpec spec -> do
|
||||
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
|
||||
pure ()
|
||||
case r of
|
||||
VRight _ -> do
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
where
|
||||
checkDuplicate :: Eq a => [a] -> a -> Duplicate
|
||||
checkDuplicate xs a
|
||||
| last xs == a = DuplicateLast
|
||||
| a `elem` xs = Duplicate
|
||||
| otherwise = NoDuplicate
|
||||
|
||||
-- appends the element to the end of the list, but also removes it from the existing list
|
||||
appendUnique :: Eq a => [a] -> a -> [a]
|
||||
appendUnique xs' e = go xs'
|
||||
where
|
||||
go [] = [e]
|
||||
go (x:xs)
|
||||
| x == e = go xs -- skip
|
||||
| otherwise = x : go xs
|
||||
|
||||
doConfig :: MonadIO m => UserSettings -> m ()
|
||||
doConfig usersettings = do
|
||||
let settings' = updateSettings usersettings userConf
|
||||
path <- liftIO getConfigFilePath
|
||||
liftIO $ writeFile path $ formatConfig $ settings'
|
||||
runLogger $ logDebug $ T.pack $ show settings'
|
||||
pure ()
|
||||
|
||||
decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
|
||||
@@ -1,119 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.DInfo where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Version
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import Language.Haskell.TH
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
-----------------
|
||||
|
||||
|
||||
describe_result :: String
|
||||
describe_result = $( LitE . StringL <$>
|
||||
runIO (do
|
||||
CapturedProcess{..} <- do
|
||||
dirs <- liftIO getAllDirs
|
||||
let settings = AppState (defaultSettings { noNetwork = True })
|
||||
dirs
|
||||
defaultKeyBindings
|
||||
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
|
||||
ExitFailure _ -> pure numericVer
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
prettyDebugInfo :: DebugInfo -> String
|
||||
prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
|
||||
"==========" <> "\n" <>
|
||||
"GHCup base dir: " <> diBaseDir <> "\n" <>
|
||||
"GHCup bin dir: " <> diBinDir <> "\n" <>
|
||||
"GHCup GHC directory: " <> diGHCDir <> "\n" <>
|
||||
"GHCup cache directory: " <> diCacheDir <> "\n" <>
|
||||
"Architecture: " <> prettyShow diArch <> "\n" <>
|
||||
"Platform: " <> prettyShow diPlatform <> "\n" <>
|
||||
"Version: " <> describe_result
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
|
||||
|
||||
runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
|
||||
-> Excepts DInfoEffects (ReaderT env m) a
|
||||
-> m (VEither DInfoEffects a)
|
||||
runDebugInfo runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@DInfoEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
dinfo :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, Alternative m
|
||||
)
|
||||
=> (ReaderT AppState m (VEither DInfoEffects DebugInfo)
|
||||
-> m (VEither DInfoEffects DebugInfo))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
dinfo runAppState runLogger = do
|
||||
runDebugInfo runAppState (liftE getDebugInfo)
|
||||
>>= \case
|
||||
VRight di -> do
|
||||
liftIO $ putStrLn $ prettyDebugInfo di
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 8
|
||||
@@ -1,142 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.GC where
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data GCOptions = GCOptions
|
||||
{ gcOldGHC :: Bool
|
||||
, gcProfilingLibs :: Bool
|
||||
, gcShareDir :: Bool
|
||||
, gcHLSNoGHC :: Bool
|
||||
, gcCache :: Bool
|
||||
, gcTmp :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
gcP :: Parser GCOptions
|
||||
gcP =
|
||||
GCOptions
|
||||
<$>
|
||||
switch
|
||||
(short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
|
||||
<*>
|
||||
switch
|
||||
(short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
|
||||
<*>
|
||||
switch
|
||||
(short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
|
||||
<*>
|
||||
switch
|
||||
(short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
|
||||
<*>
|
||||
switch
|
||||
(short 'c' <> long "cache" <> help "GC the GHCup cache")
|
||||
<*>
|
||||
switch
|
||||
(short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
gcFooter :: String
|
||||
gcFooter = [s|Discussion:
|
||||
Performs garbage collection. If no switches are specified, does nothing.|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type GCEffects = '[ NotInstalled, UninstallFailed ]
|
||||
|
||||
|
||||
runGC :: MonadUnliftIO m
|
||||
=> (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
|
||||
-> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither GCEffects a)
|
||||
runGC runAppState =
|
||||
runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@GCEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
gc :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GCOptions
|
||||
-> (forall a. ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
gc GCOptions{..} runAppState runLogger = runGC runAppState (do
|
||||
when gcOldGHC (liftE rmOldGHC)
|
||||
lift $ when gcProfilingLibs rmProfilingLibs
|
||||
lift $ when gcShareDir rmShareDir
|
||||
liftE $ when gcHLSNoGHC rmHLSNoGHC
|
||||
lift $ when gcCache rmCache
|
||||
lift $ when gcTmp rmTmp
|
||||
) >>= \case
|
||||
VRight _ -> do
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 27
|
||||
@@ -1,539 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.OptParse.Install where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Codec.Archive
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import URI.ByteString hiding ( uriParser )
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data InstallCommand = InstallGHC InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
| InstallHLS InstallOptions
|
||||
| InstallStack InstallOptions
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
, instBindist :: Maybe URI
|
||||
, instSet :: Bool
|
||||
, isolateDir :: Maybe FilePath
|
||||
, forceInstall :: Bool
|
||||
, addConfArgs :: [T.Text]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Footers ]--
|
||||
---------------
|
||||
|
||||
installCabalFooter :: String
|
||||
installCabalFooter = [s|Discussion:
|
||||
Installs the specified cabal-install version (or a recommended default one)
|
||||
into "~/.ghcup/bin", so it can be overwritten by later
|
||||
"cabal install cabal-install", which installs into "~/.cabal/bin" by
|
||||
default. Make sure to set up your PATH appropriately, so the cabal
|
||||
installation takes precedence.|]
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
installParser :: Parser (Either InstallCommand InstallOptions)
|
||||
installParser =
|
||||
(Left <$> subparser
|
||||
( command
|
||||
"ghc"
|
||||
( InstallGHC
|
||||
<$> info
|
||||
(installOpts (Just GHC) <**> helper)
|
||||
( progDesc "Install GHC"
|
||||
<> footerDoc (Just $ text installGHCFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( InstallCabal
|
||||
<$> info
|
||||
(installOpts (Just Cabal) <**> helper)
|
||||
( progDesc "Install Cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( InstallHLS
|
||||
<$> info
|
||||
(installOpts (Just HLS) <**> helper)
|
||||
( progDesc "Install haskell-language-server"
|
||||
<> footerDoc (Just $ text installHLSFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( InstallStack
|
||||
<$> info
|
||||
(installOpts (Just Stack) <**> helper)
|
||||
( progDesc "Install stack"
|
||||
<> footerDoc (Just $ text installStackFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> installOpts Nothing)
|
||||
where
|
||||
installHLSFooter :: String
|
||||
installHLSFooter = [s|Discussion:
|
||||
Installs haskell-language-server binaries and wrapper
|
||||
into "~/.ghcup/bin"
|
||||
|
||||
Examples:
|
||||
# install recommended HLS
|
||||
ghcup install hls|]
|
||||
|
||||
installStackFooter :: String
|
||||
installStackFooter = [s|Discussion:
|
||||
Installs stack binaries into "~/.ghcup/bin"
|
||||
|
||||
Examples:
|
||||
# install recommended Stack
|
||||
ghcup install stack|]
|
||||
|
||||
installGHCFooter :: String
|
||||
installGHCFooter = [s|Discussion:
|
||||
Installs the specified GHC version (or a recommended default one) into
|
||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||
|
||||
Examples:
|
||||
# install recommended GHC
|
||||
ghcup install ghc
|
||||
|
||||
# install latest GHC
|
||||
ghcup install ghc latest
|
||||
|
||||
# install GHC 8.10.2
|
||||
ghcup install ghc 8.10.2
|
||||
|
||||
# install GHC head fedora bindist
|
||||
ghcup install ghc -u 'https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head|]
|
||||
|
||||
|
||||
installOpts :: Maybe Tool -> Parser InstallOptions
|
||||
installOpts tool =
|
||||
(\(u, v) b is f -> InstallOptions v u b is f)
|
||||
<$> ( ( (,)
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader uriParser)
|
||||
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
|
||||
"Install the specified version from this bindist"
|
||||
<> completer (toolDlCompleter (fromMaybe GHC tool))
|
||||
)
|
||||
)
|
||||
<*> (Just <$> toolVersionTagArgument [] tool)
|
||||
)
|
||||
<|> pure (Nothing, Nothing)
|
||||
)
|
||||
<*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault
|
||||
(help $ if not setDefault then "Set as active version after install" else "Don't set as active version after install"))
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader isolateParser)
|
||||
( short 'i'
|
||||
<> long "isolate"
|
||||
<> metavar "DIR"
|
||||
<> help "install in an isolated absolute directory instead of the default one"
|
||||
<> completer (bashCompleter "directory")
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
(short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
|
||||
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
|
||||
where
|
||||
setDefault = case tool of
|
||||
Nothing -> False
|
||||
Just GHC -> False
|
||||
Just _ -> True
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
installToolFooter :: String
|
||||
installToolFooter = [s|Discussion:
|
||||
Installs GHC or cabal. When no command is given, installs GHC
|
||||
with the specified version/tag.
|
||||
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
type InstallEffects = '[ AlreadyInstalled
|
||||
, UnknownArchive
|
||||
, ArchiveResult
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, NotInstalled
|
||||
, DirNotEmpty
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, TarDirDoesNotExist
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, FileAlreadyExistsError
|
||||
, ProcessError
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
, InstallSetError
|
||||
]
|
||||
|
||||
|
||||
runInstTool :: AppState
|
||||
-> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
|
||||
-> IO (VEither InstallEffects a)
|
||||
runInstTool appstate' =
|
||||
flip runReaderT appstate'
|
||||
. runResourceT
|
||||
. runE
|
||||
@InstallEffects
|
||||
|
||||
|
||||
type InstallGHCEffects = '[ AlreadyInstalled
|
||||
, ArchiveResult
|
||||
, BuildFailed
|
||||
, CopyError
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, DirNotEmpty
|
||||
, DownloadFailed
|
||||
, FileAlreadyExistsError
|
||||
, FileDoesNotExistError
|
||||
, GPGError
|
||||
, MergeFileTreeError
|
||||
, NextVerNotFound
|
||||
, NoDownload
|
||||
, NoToolVersionSet
|
||||
, NotInstalled
|
||||
, ProcessError
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, TarDirDoesNotExist
|
||||
, UninstallFailed
|
||||
, UnknownArchive
|
||||
, InstallSetError
|
||||
]
|
||||
|
||||
runInstGHC :: AppState
|
||||
-> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a
|
||||
-> IO (VEither InstallGHCEffects a)
|
||||
runInstGHC appstate' =
|
||||
flip runReaderT appstate'
|
||||
. runResourceT
|
||||
. runE
|
||||
@InstallGHCEffects
|
||||
|
||||
|
||||
-------------------
|
||||
--[ Entrypoints ]--
|
||||
-------------------
|
||||
|
||||
|
||||
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
|
||||
install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(Right iopts) -> do
|
||||
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
|
||||
installGHC iopts
|
||||
(Left (InstallGHC iopts)) -> installGHC iopts
|
||||
(Left (InstallCabal iopts)) -> installCabal iopts
|
||||
(Left (InstallHLS iopts)) -> installHLS iopts
|
||||
(Left (InstallStack iopts)) -> installStack iopts
|
||||
where
|
||||
installGHC :: InstallOptions -> IO ExitCode
|
||||
installGHC InstallOptions{..} = do
|
||||
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
|
||||
(case instBindist of
|
||||
Nothing -> runInstGHC s' $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ runBothE' (installGHCBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
addConfArgs
|
||||
)
|
||||
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstGHC s'{ settings = settings {noVerify = True}} $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ runBothE' (installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
addConfArgs
|
||||
)
|
||||
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ logInfo "GHC installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
|
||||
VLeft (V (DirNotEmpty fp)) -> do
|
||||
runLogger $ logError $
|
||||
"Install directory " <> T.pack fp <> " is not empty."
|
||||
pure $ ExitFailure 3
|
||||
VLeft (V (DirNotEmpty fp)) -> do
|
||||
runLogger $ logError $
|
||||
"Install directory " <> T.pack fp <> " is not empty."
|
||||
pure $ ExitFailure 3
|
||||
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger (logError $ T.pack $ prettyHFError err)
|
||||
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
|
||||
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
pure $ ExitFailure 3
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger (logError $ T.pack $ prettyHFError err)
|
||||
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
|
||||
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
pure $ ExitFailure 3
|
||||
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
logError $ T.pack $ prettyHFError e
|
||||
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||
pure $ ExitFailure 3
|
||||
|
||||
|
||||
installCabal :: InstallOptions -> IO ExitCode
|
||||
installCabal InstallOptions{..} = do
|
||||
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool s' $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ runBothE' (installCabalBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstTool s'{ settings = settings { noVerify = True}} $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ runBothE' (installCabalBindist
|
||||
(DownloadInfo uri Nothing "" Nothing Nothing)
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ logInfo "Cabal installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
logError $ T.pack $ prettyHFError e
|
||||
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||
pure $ ExitFailure 4
|
||||
|
||||
installHLS :: InstallOptions -> IO ExitCode
|
||||
installHLS InstallOptions{..} = do
|
||||
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool s' $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ runBothE' (installHLSBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstTool s'{ settings = settings { noVerify = True}} $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
|
||||
-- TODO: support legacy
|
||||
liftE $ runBothE' (installHLSBindist
|
||||
(DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ logInfo "HLS installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
logError $ T.pack $ prettyHFError e
|
||||
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||
pure $ ExitFailure 4
|
||||
|
||||
installStack :: InstallOptions -> IO ExitCode
|
||||
installStack InstallOptions{..} = do
|
||||
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool s' $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ runBothE' (installStackBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstTool s'{ settings = settings { noVerify = True}} $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ runBothE' (installStackBindist
|
||||
(DownloadInfo uri Nothing "" Nothing Nothing)
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ logInfo "Stack installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyHFError e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
logError $ T.pack $ prettyHFError e
|
||||
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||
pure $ ExitFailure 4
|
||||
@@ -1,314 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.List where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Char
|
||||
import Data.List ( intercalate, sort )
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Versions hiding ( str )
|
||||
import Data.Void
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import System.Console.Pretty hiding ( color )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified System.Console.Pretty as Pretty
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Text.Megaparsec.Char as MPC
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data ListOptions = ListOptions
|
||||
{ loTool :: Maybe Tool
|
||||
, lCriteria :: Maybe ListCriteria
|
||||
, lFrom :: Maybe Day
|
||||
, lTo :: Maybe Day
|
||||
, lHideOld :: Bool
|
||||
, lShowNightly :: Bool
|
||||
, lRawFormat :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
listOpts :: Parser ListOptions
|
||||
listOpts =
|
||||
ListOptions
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader toolParser)
|
||||
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
|
||||
"Tool to list versions for. Default is all"
|
||||
<> completer toolCompleter
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader criteriaParser)
|
||||
( short 'c'
|
||||
<> long "show-criteria"
|
||||
<> metavar "<installed|set|available>"
|
||||
<> help "Apply filtering criteria, prefix with + or -"
|
||||
<> completer (listCompleter
|
||||
[ "+installed", "+set", "+available", "-installed", "-set", "-available"])
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader dayParser)
|
||||
(short 's' <> long "since" <> metavar "YYYY-MM-DD" <> help
|
||||
"List only tools with release date starting at YYYY-MM-DD or later"
|
||||
<> completer toolCompleter
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader dayParser)
|
||||
(short 'u' <> long "until" <> metavar "YYYY-MM-DD" <> help
|
||||
"List only tools with release date earlier than YYYY-MM-DD"
|
||||
<> completer toolCompleter
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
(short 'o' <> long "hide-old" <> help "Hide 'old' GHC versions (installed ones are always shown)"
|
||||
)
|
||||
<*> switch
|
||||
(short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)"
|
||||
)
|
||||
<*> switch
|
||||
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
|
||||
)
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
listToolFooter :: String
|
||||
listToolFooter = [s|Discussion:
|
||||
Lists tool versions with optional criteria.
|
||||
Nightlies are by default hidden.
|
||||
|
||||
Examples:
|
||||
# query nightlies in a specific range
|
||||
ghcup list --show-nightly --since 2022-12-07 --until 2022-12-31
|
||||
# show all installed GHC versions
|
||||
ghcup list -t ghc -c installed|]
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
-----------------
|
||||
|
||||
|
||||
printListResult :: Bool -> Bool -> [ListResult] -> IO ()
|
||||
printListResult no_color raw lr = do
|
||||
|
||||
let
|
||||
color | raw || no_color = (\_ x -> x)
|
||||
| otherwise = Pretty.color
|
||||
|
||||
let
|
||||
printTag Recommended = color Green "recommended"
|
||||
printTag Latest = color Yellow "latest"
|
||||
printTag Prerelease = color Red "prerelease"
|
||||
printTag Nightly = color Red "nightly"
|
||||
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
|
||||
printTag (UnknownTag t ) = t
|
||||
printTag LatestPrerelease = color Red "latest-prerelease"
|
||||
printTag LatestNightly = color Red "latest-nightly"
|
||||
printTag Old = ""
|
||||
|
||||
let
|
||||
rows =
|
||||
(\x -> if raw
|
||||
then x
|
||||
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
|
||||
)
|
||||
. fmap
|
||||
(\ListResult {..} ->
|
||||
let marks = if
|
||||
| lSet -> (color Green (if isWindows then "IS" else "✔✔"))
|
||||
| lInstalled -> (color Green (if isWindows then "I " else "✓ "))
|
||||
| otherwise -> (color Red (if isWindows then "X " else "✗ "))
|
||||
in
|
||||
(if raw then [] else [marks])
|
||||
++ [ fmap toLower . show $ lTool
|
||||
, case lCross of
|
||||
Nothing -> T.unpack . prettyVer $ lVer
|
||||
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
|
||||
, intercalate "," (filter (/= "") . fmap printTag $ sort lTag)
|
||||
, intercalate ","
|
||||
$ (if hlsPowered
|
||||
then [color Green "hls-powered"]
|
||||
else mempty
|
||||
)
|
||||
++ (if lStray then [color Yellow "stray"] else mempty)
|
||||
++ (case lReleaseDay of
|
||||
Nothing -> mempty
|
||||
Just d -> [color Blue (show d)])
|
||||
++ (if lNoBindist
|
||||
then [color Red "no-bindist"]
|
||||
else mempty
|
||||
)
|
||||
]
|
||||
)
|
||||
$ lr
|
||||
let cols =
|
||||
foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows
|
||||
lengths = fmap (maximum . fmap strWidth) cols
|
||||
padded = fmap (\xs -> zipWith padTo xs lengths) rows
|
||||
|
||||
forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row
|
||||
where
|
||||
|
||||
padTo str' x =
|
||||
let lstr = strWidth str'
|
||||
add' = x - lstr
|
||||
in if add' < 0 then str' else str' ++ replicate add' ' '
|
||||
|
||||
-- | Calculate the render width of a string, considering
|
||||
-- wide characters (counted as double width), ANSI escape codes
|
||||
-- (not counted), and line breaks (in a multi-line string, the longest
|
||||
-- line determines the width).
|
||||
strWidth :: String -> Int
|
||||
strWidth =
|
||||
maximum
|
||||
. (0 :)
|
||||
. map (foldr (\a b -> charWidth a + b) 0)
|
||||
. lines
|
||||
. stripAnsi
|
||||
|
||||
-- | Strip ANSI escape sequences from a string.
|
||||
--
|
||||
-- >>> stripAnsi "\ESC[31m-1\ESC[m"
|
||||
-- "-1"
|
||||
stripAnsi :: String -> String
|
||||
stripAnsi s' =
|
||||
case
|
||||
MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
|
||||
of
|
||||
Nothing -> error "Bad ansi escape" -- PARTIAL: should not happen
|
||||
Just xs -> concat xs
|
||||
where
|
||||
-- This parses lots of invalid ANSI escape codes, but that should be fine
|
||||
ansi =
|
||||
MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
|
||||
Void
|
||||
String
|
||||
Char
|
||||
digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
|
||||
suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
|
||||
|
||||
-- | Get the designated render width of a character: 0 for a combining
|
||||
-- character, 1 for a regular character, 2 for a wide character.
|
||||
-- (Wide characters are rendered as exactly double width in apps and
|
||||
-- fonts that support it.) (From Pandoc.)
|
||||
charWidth :: Char -> Int
|
||||
charWidth c = case c of
|
||||
_ | c < '\x0300' -> 1
|
||||
| c >= '\x0300' && c <= '\x036F' -> 0
|
||||
| -- combining
|
||||
c >= '\x0370' && c <= '\x10FC' -> 1
|
||||
| c >= '\x1100' && c <= '\x115F' -> 2
|
||||
| c >= '\x1160' && c <= '\x11A2' -> 1
|
||||
| c >= '\x11A3' && c <= '\x11A7' -> 2
|
||||
| c >= '\x11A8' && c <= '\x11F9' -> 1
|
||||
| c >= '\x11FA' && c <= '\x11FF' -> 2
|
||||
| c >= '\x1200' && c <= '\x2328' -> 1
|
||||
| c >= '\x2329' && c <= '\x232A' -> 2
|
||||
| c >= '\x232B' && c <= '\x2E31' -> 1
|
||||
| c >= '\x2E80' && c <= '\x303E' -> 2
|
||||
| c == '\x303F' -> 1
|
||||
| c >= '\x3041' && c <= '\x3247' -> 2
|
||||
| c >= '\x3248' && c <= '\x324F' -> 1
|
||||
| -- ambiguous
|
||||
c >= '\x3250' && c <= '\x4DBF' -> 2
|
||||
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
|
||||
| c >= '\x4E00' && c <= '\xA4C6' -> 2
|
||||
| c >= '\xA4D0' && c <= '\xA95F' -> 1
|
||||
| c >= '\xA960' && c <= '\xA97C' -> 2
|
||||
| c >= '\xA980' && c <= '\xABF9' -> 1
|
||||
| c >= '\xAC00' && c <= '\xD7FB' -> 2
|
||||
| c >= '\xD800' && c <= '\xDFFF' -> 1
|
||||
| c >= '\xE000' && c <= '\xF8FF' -> 1
|
||||
| -- ambiguous
|
||||
c >= '\xF900' && c <= '\xFAFF' -> 2
|
||||
| c >= '\xFB00' && c <= '\xFDFD' -> 1
|
||||
| c >= '\xFE00' && c <= '\xFE0F' -> 1
|
||||
| -- ambiguous
|
||||
c >= '\xFE10' && c <= '\xFE19' -> 2
|
||||
| c >= '\xFE20' && c <= '\xFE26' -> 1
|
||||
| c >= '\xFE30' && c <= '\xFE6B' -> 2
|
||||
| c >= '\xFE70' && c <= '\xFEFF' -> 1
|
||||
| c >= '\xFF01' && c <= '\xFF60' -> 2
|
||||
| c >= '\xFF61' && c <= '\x16A38' -> 1
|
||||
| c >= '\x1B000' && c <= '\x1B001' -> 2
|
||||
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
|
||||
| c >= '\x1F200' && c <= '\x1F251' -> 2
|
||||
| c >= '\x1F300' && c <= '\x1F773' -> 1
|
||||
| c >= '\x20000' && c <= '\x3FFFD' -> 2
|
||||
| otherwise -> 1
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
list :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> ListOptions
|
||||
-> Bool
|
||||
-> (ReaderT AppState m ExitCode -> m ExitCode)
|
||||
-> m ExitCode
|
||||
list ListOptions{..} no_color runAppState =
|
||||
runAppState (do
|
||||
l <- listVersions loTool (maybeToList lCriteria) lHideOld lShowNightly (lFrom, lTo)
|
||||
liftIO $ printListResult no_color lRawFormat l
|
||||
pure ExitSuccess
|
||||
)
|
||||
@@ -1,98 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Nuke where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.Logger
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Control.Concurrent (threadDelay)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type NukeEffects = '[ NotInstalled, UninstallFailed ]
|
||||
|
||||
|
||||
runNuke :: AppState
|
||||
-> Excepts NukeEffects (ReaderT AppState m) a
|
||||
-> m (VEither NukeEffects a)
|
||||
runNuke s' =
|
||||
flip runReaderT s' . runE @NukeEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
nuke :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> IO AppState
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
nuke appState runLogger = do
|
||||
s' <- liftIO appState
|
||||
void $ liftIO $ evaluate $ force s'
|
||||
runNuke s' (do
|
||||
lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
|
||||
lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
|
||||
liftIO $ threadDelay 10000000 -- wait 10s
|
||||
|
||||
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
|
||||
lift $ logInfo "Nuking in 3...2...1"
|
||||
|
||||
lInstalled <- lift $ listVersions Nothing [ListInstalled True] False True (Nothing, Nothing)
|
||||
|
||||
forM_ lInstalled (liftE . rmTool)
|
||||
|
||||
lift rmGhcupDirs
|
||||
|
||||
) >>= \case
|
||||
VRight leftOverFiles
|
||||
| null leftOverFiles -> do
|
||||
runLogger $ logInfo "Nuclear Annihilation complete!"
|
||||
pure ExitSuccess
|
||||
| otherwise -> do
|
||||
runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
|
||||
liftIO $ forM_ leftOverFiles putStrLn
|
||||
pure ExitSuccess
|
||||
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 15
|
||||
@@ -1,220 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Prefetch where
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Download (getDownloadsF)
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
|
||||
| PrefetchCabal PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchHLS PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchStack PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchMetadata
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data PrefetchOptions = PrefetchOptions {
|
||||
pfCacheDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
data PrefetchGHCOptions = PrefetchGHCOptions {
|
||||
pfGHCSrc :: Bool
|
||||
, pfGHCCacheDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
prefetchP :: Parser PrefetchCommand
|
||||
prefetchP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
(info
|
||||
(PrefetchGHC
|
||||
<$> (PrefetchGHCOptions
|
||||
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
|
||||
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
|
||||
<*> optional (toolVersionTagArgument [] (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/)" <> completer (bashCompleter "directory"))))
|
||||
<*> ( optional (toolVersionTagArgument [] (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/)" <> completer (bashCompleter "directory"))))
|
||||
<*> ( optional (toolVersionTagArgument [] (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/)" <> completer (bashCompleter "directory"))))
|
||||
<*> ( optional (toolVersionTagArgument [] (Just Stack)) <**> helper ))
|
||||
( progDesc "Download stack assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"metadata"
|
||||
(PrefetchMetadata <$ info
|
||||
helper
|
||||
( progDesc "Download ghcup's metadata, needed for various operations")
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
prefetchFooter :: String
|
||||
prefetchFooter = [s|Discussion:
|
||||
Prefetches tools or assets into "~/.ghcup/cache" directory. This can
|
||||
be then combined later with '--offline' flag, ensuring all assets that
|
||||
are required for offline use have been prefetched.
|
||||
|
||||
Examples:
|
||||
ghcup prefetch metadata
|
||||
ghcup prefetch ghc 8.10.5
|
||||
ghcup --offline install ghc 8.10.5|]
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type PrefetchEffects = '[ TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, NoDownload
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, JSONError
|
||||
, FileDoesNotExistError ]
|
||||
|
||||
|
||||
runPrefetch :: MonadUnliftIO m
|
||||
=> (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
|
||||
-> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither PrefetchEffects a)
|
||||
runPrefetch runAppState =
|
||||
runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@PrefetchEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
prefetch :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> PrefetchCommand
|
||||
-> (forall a. ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
prefetch prefetchCommand runAppState runLogger =
|
||||
runPrefetch runAppState (do
|
||||
case prefetchCommand of
|
||||
PrefetchGHC
|
||||
(PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt GHC
|
||||
if pfGHCSrc
|
||||
then liftE $ fetchGHCSrc 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 $ prettyHFError e
|
||||
pure $ ExitFailure 15
|
||||
@@ -1,232 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Rm where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.Versions hiding ( str )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data RmCommand = RmGHC RmOptions
|
||||
| RmCabal Version
|
||||
| RmHLS Version
|
||||
| RmStack Version
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data RmOptions = RmOptions
|
||||
{ ghcVer :: GHCTargetVersion
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
rmParser :: Parser (Either RmCommand RmOptions)
|
||||
rmParser =
|
||||
(Left <$> subparser
|
||||
( command
|
||||
"ghc"
|
||||
(RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
|
||||
<> command
|
||||
"cabal"
|
||||
( RmCabal
|
||||
<$> info (versionParser' [ListInstalled True] (Just Cabal) <**> helper)
|
||||
(progDesc "Remove Cabal version")
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( RmHLS
|
||||
<$> info (versionParser' [ListInstalled True] (Just HLS) <**> helper)
|
||||
(progDesc "Remove haskell-language-server version")
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( RmStack
|
||||
<$> info (versionParser' [ListInstalled True] (Just Stack) <**> helper)
|
||||
(progDesc "Remove stack version")
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> rmOpts Nothing)
|
||||
|
||||
|
||||
|
||||
rmOpts :: Maybe Tool -> Parser RmOptions
|
||||
rmOpts tool = RmOptions <$> ghcVersionArgument [ListInstalled True] tool
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
rmFooter :: String
|
||||
rmFooter = [s|Discussion:
|
||||
Remove the given GHC or cabal version. When no command is given,
|
||||
defaults to removing GHC with the specified version.
|
||||
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type RmEffects = '[ NotInstalled, UninstallFailed ]
|
||||
|
||||
|
||||
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
|
||||
-> Excepts RmEffects (ReaderT env m) a
|
||||
-> m (VEither RmEffects a)
|
||||
runRm runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@RmEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
rm :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Either RmCommand RmOptions
|
||||
-> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
|
||||
-> m (VEither RmEffects (Maybe VersionInfo)))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
rm rmCommand runAppState runLogger = case rmCommand of
|
||||
(Right rmopts) -> do
|
||||
runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
|
||||
rmGHC' rmopts
|
||||
(Left (RmGHC rmopts)) -> rmGHC' rmopts
|
||||
(Left (RmCabal rmopts)) -> rmCabal' rmopts
|
||||
(Left (RmHLS rmopts)) -> rmHLS' rmopts
|
||||
(Left (RmStack rmopts)) -> rmStack' rmopts
|
||||
|
||||
where
|
||||
rmGHC' RmOptions{..} =
|
||||
runRm runAppState (do
|
||||
liftE $
|
||||
rmGHCVer ghcVer
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo ghcVer GHC dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ logGHCPostRm ghcVer
|
||||
postRmLog vi
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 7
|
||||
|
||||
rmCabal' tv =
|
||||
runRm runAppState (do
|
||||
liftE $
|
||||
rmCabalVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo (mkTVer tv) Cabal dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
postRmLog vi
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
rmHLS' tv =
|
||||
runRm runAppState (do
|
||||
liftE $
|
||||
rmHLSVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo (mkTVer tv) HLS dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
postRmLog vi
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
rmStack' tv =
|
||||
runRm runAppState (do
|
||||
liftE $
|
||||
rmStackVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo (mkTVer tv) Stack dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
postRmLog vi
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
postRmLog vi =
|
||||
forM_ (_viPostRemove =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
@@ -1,495 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module GHCup.OptParse.Run where
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Utils
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
#ifdef IS_WINDOWS
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.Process.Windows ( execNoMinGW )
|
||||
#endif
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Control.Exception.Safe ( MonadMask, MonadCatch )
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Codec.Archive
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.List ( intercalate )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.FilePath
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
#ifndef IS_WINDOWS
|
||||
import qualified System.Posix.Process as SPP
|
||||
#endif
|
||||
import Data.Versions ( prettyVer, Version )
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data RunOptions = RunOptions
|
||||
{ runAppendPATH :: Bool
|
||||
, runInstTool' :: Bool
|
||||
, runMinGWPath :: Bool
|
||||
, runGHCVer :: Maybe ToolVersion
|
||||
, runCabalVer :: Maybe ToolVersion
|
||||
, runHLSVer :: Maybe ToolVersion
|
||||
, runStackVer :: Maybe ToolVersion
|
||||
, runBinDir :: Maybe FilePath
|
||||
, runQuick :: Bool
|
||||
, runCOMMAND :: [String]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
|
||||
runOpts :: Parser RunOptions
|
||||
runOpts =
|
||||
RunOptions
|
||||
<$> switch
|
||||
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
|
||||
<*> switch
|
||||
(short 'i' <> long "install" <> help "Install the tool, if missing")
|
||||
<*> switch
|
||||
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader ghcVersionTagEither)
|
||||
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
|
||||
<> completer (tagCompleter GHC [])
|
||||
<> (completer $ versionCompleter [] GHC)
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader toolVersionTagEither)
|
||||
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
|
||||
<> completer (tagCompleter Cabal [])
|
||||
<> (completer $ versionCompleter [] Cabal)
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader toolVersionTagEither)
|
||||
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
|
||||
<> completer (tagCompleter HLS [])
|
||||
<> (completer $ versionCompleter [] HLS)
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader toolVersionTagEither)
|
||||
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
|
||||
<> completer (tagCompleter Stack [])
|
||||
<> (completer $ versionCompleter [] Stack)
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader isolateParser)
|
||||
( short 'b'
|
||||
<> long "bindir"
|
||||
<> metavar "DIR"
|
||||
<> help "directory where to create the tool symlinks (default: newly created system temp dir)"
|
||||
<> completer (bashCompleter "directory")
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
|
||||
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
runFooter :: String
|
||||
runFooter = [s|Discussion:
|
||||
Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing
|
||||
the relevant binaries, then executes a command.
|
||||
|
||||
Examples:
|
||||
# run VSCode with all latest toolchain exposed, installing missing versions if necessary
|
||||
ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs
|
||||
|
||||
# create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH
|
||||
ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin
|
||||
|
||||
# run a specific ghc version
|
||||
ghcup run --ghc 8.10.7 -- ghc --version|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type RunEffects = '[ AlreadyInstalled
|
||||
, UnknownArchive
|
||||
, ArchiveResult
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, NotInstalled
|
||||
, DirNotEmpty
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, TarDirDoesNotExist
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, FileAlreadyExistsError
|
||||
, ProcessError
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
]
|
||||
|
||||
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
|
||||
=> LeanAppState
|
||||
-> Excepts RunEffects (ReaderT LeanAppState m) a
|
||||
-> m (VEither RunEffects a)
|
||||
runLeanRUN leanAppstate =
|
||||
-- Don't use runLeanAppState here, which is disabled on windows.
|
||||
-- This is the only command on all platforms that doesn't need full appstate.
|
||||
flip runReaderT leanAppstate
|
||||
. runE
|
||||
@RunEffects
|
||||
|
||||
runRUN :: MonadUnliftIO m
|
||||
=> IO AppState
|
||||
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither RunEffects a)
|
||||
runRUN appState action' = do
|
||||
s' <- liftIO appState
|
||||
flip runReaderT s'
|
||||
. runResourceT
|
||||
. runE
|
||||
@RunEffects
|
||||
$ action'
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
run :: forall m .
|
||||
( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> RunOptions
|
||||
-> IO AppState
|
||||
-> LeanAppState
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
run RunOptions{..} runAppState leanAppstate runLogger = do
|
||||
r <- if not runQuick
|
||||
then runRUN runAppState $ do
|
||||
toolchain <- liftE resolveToolchainFull
|
||||
|
||||
-- oh dear
|
||||
r <- lift ask
|
||||
tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain
|
||||
|
||||
liftE $ installToolChainFull toolchain tmp
|
||||
pure tmp
|
||||
else runLeanRUN leanAppstate $ do
|
||||
toolchain <- resolveToolchain
|
||||
tmp <- lift $ createTmpDir toolchain
|
||||
liftE $ installToolChain toolchain tmp
|
||||
pure tmp
|
||||
case r of
|
||||
VRight tmp -> do
|
||||
case runCOMMAND of
|
||||
[] -> do
|
||||
liftIO $ putStr tmp
|
||||
pure ExitSuccess
|
||||
(cmd:args) -> do
|
||||
newEnv <- liftIO $ addToPath tmp runAppendPATH
|
||||
#ifndef IS_WINDOWS
|
||||
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
|
||||
pure ExitSuccess
|
||||
#else
|
||||
r' <- if runMinGWPath
|
||||
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
|
||||
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
|
||||
case r' of
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 28
|
||||
#endif
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 27
|
||||
|
||||
where
|
||||
|
||||
-- TODO: doesn't work for cross
|
||||
resolveToolchainFull :: ( MonadFail m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Excepts
|
||||
'[ TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] (ResourceT (ReaderT AppState m)) Toolchain
|
||||
resolveToolchainFull = do
|
||||
ghcVer <- forM runGHCVer $ \ver -> do
|
||||
(v, _) <- liftE $ fromVersion (Just ver) GHC
|
||||
pure v
|
||||
cabalVer <- forM runCabalVer $ \ver -> do
|
||||
(v, _) <- liftE $ fromVersion (Just ver) Cabal
|
||||
pure (_tvVersion v)
|
||||
hlsVer <- forM runHLSVer $ \ver -> do
|
||||
(v, _) <- liftE $ fromVersion (Just ver) HLS
|
||||
pure (_tvVersion v)
|
||||
stackVer <- forM runStackVer $ \ver -> do
|
||||
(v, _) <- liftE $ fromVersion (Just ver) Stack
|
||||
pure (_tvVersion v)
|
||||
pure Toolchain{..}
|
||||
|
||||
resolveToolchain = do
|
||||
ghcVer <- case runGHCVer of
|
||||
Just (GHCVersion v) -> pure $ Just v
|
||||
Just (ToolVersion v) -> pure $ Just (mkTVer v)
|
||||
Nothing -> pure Nothing
|
||||
_ -> fail "Internal error"
|
||||
cabalVer <- case runCabalVer of
|
||||
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
||||
Just (ToolVersion v) -> pure $ Just v
|
||||
Nothing -> pure Nothing
|
||||
_ -> fail "Internal error"
|
||||
hlsVer <- case runHLSVer of
|
||||
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
||||
Just (ToolVersion v) -> pure $ Just v
|
||||
Nothing -> pure Nothing
|
||||
_ -> fail "Internal error"
|
||||
stackVer <- case runStackVer of
|
||||
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
||||
Just (ToolVersion v) -> pure $ Just v
|
||||
Nothing -> pure Nothing
|
||||
_ -> fail "Internal error"
|
||||
pure Toolchain{..}
|
||||
|
||||
installToolChainFull :: ( MonadFail m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Toolchain
|
||||
-> FilePath
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ProcessError
|
||||
, NotInstalled
|
||||
, NoDownload
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, DirNotEmpty
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, BuildFailed
|
||||
, ArchiveResult
|
||||
, AlreadyInstalled
|
||||
, FileAlreadyExistsError
|
||||
, CopyError
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
] (ResourceT (ReaderT AppState m)) ()
|
||||
installToolChainFull Toolchain{..} tmp = do
|
||||
case ghcVer of
|
||||
Just v -> do
|
||||
isInstalled <- lift $ checkIfToolInstalled' GHC v
|
||||
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
|
||||
v
|
||||
GHCupInternal
|
||||
False
|
||||
[]
|
||||
setGHC' v tmp
|
||||
_ -> pure ()
|
||||
case cabalVer of
|
||||
Just v -> do
|
||||
isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)
|
||||
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
|
||||
v
|
||||
GHCupInternal
|
||||
False
|
||||
setCabal' v tmp
|
||||
_ -> pure ()
|
||||
case stackVer of
|
||||
Just v -> do
|
||||
isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)
|
||||
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
|
||||
v
|
||||
GHCupInternal
|
||||
False
|
||||
setStack' v tmp
|
||||
_ -> pure ()
|
||||
case hlsVer of
|
||||
Just v -> do
|
||||
isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)
|
||||
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
|
||||
v
|
||||
GHCupInternal
|
||||
False
|
||||
setHLS' v tmp
|
||||
_ -> pure ()
|
||||
|
||||
installToolChain :: ( MonadFail m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Toolchain
|
||||
-> FilePath
|
||||
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
|
||||
installToolChain Toolchain{..} tmp = do
|
||||
case ghcVer of
|
||||
Just v -> setGHC' v tmp
|
||||
_ -> pure ()
|
||||
case cabalVer of
|
||||
Just v -> setCabal' v tmp
|
||||
_ -> pure ()
|
||||
case stackVer of
|
||||
Just v -> setStack' v tmp
|
||||
_ -> pure ()
|
||||
case hlsVer of
|
||||
Just v -> setHLS' v tmp
|
||||
_ -> pure ()
|
||||
|
||||
setGHC' v tmp = do
|
||||
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
|
||||
void $ liftE $ setGHC v SetGHCOnly (Just tmp)
|
||||
setCabal' v tmp = do
|
||||
bin <- liftE $ whereIsTool Cabal (mkTVer v)
|
||||
cbin <- liftIO $ canonicalizePath bin
|
||||
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
|
||||
setStack' v tmp = do
|
||||
bin <- liftE $ whereIsTool Stack (mkTVer v)
|
||||
cbin <- liftIO $ canonicalizePath bin
|
||||
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
|
||||
setHLS' v tmp = do
|
||||
Dirs {..} <- getDirs
|
||||
legacy <- isLegacyHLS v
|
||||
if legacy
|
||||
then do
|
||||
-- TODO: factor this out
|
||||
hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v))
|
||||
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
|
||||
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
|
||||
hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
|
||||
forM_ hlsBins $ \bin ->
|
||||
lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
|
||||
liftE $ setHLS v SetHLSOnly (Just tmp)
|
||||
else do
|
||||
liftE $ setHLS v SetHLS_XYZ (Just tmp)
|
||||
liftE $ setHLS v SetHLSOnly (Just tmp)
|
||||
|
||||
createTmpDir :: ( MonadUnliftIO m
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadMask m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Toolchain
|
||||
-> ReaderT LeanAppState m FilePath
|
||||
createTmpDir toolchain =
|
||||
case runBinDir of
|
||||
Just bindir -> do
|
||||
liftIO $ createDirRecursive' bindir
|
||||
liftIO $ canonicalizePath bindir
|
||||
Nothing -> do
|
||||
d <- predictableTmpDir toolchain
|
||||
liftIO $ createDirRecursive' d
|
||||
liftIO $ canonicalizePath d
|
||||
|
||||
predictableTmpDir :: Monad m
|
||||
=> Toolchain
|
||||
-> ReaderT LeanAppState m FilePath
|
||||
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do
|
||||
Dirs { tmpDir } <- getDirs
|
||||
pure (fromGHCupPath tmpDir </> "ghcup-none")
|
||||
predictableTmpDir Toolchain{..} = do
|
||||
Dirs { tmpDir } <- getDirs
|
||||
pure $ fromGHCupPath tmpDir
|
||||
</> ("ghcup-" <> intercalate "_"
|
||||
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
|
||||
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer
|
||||
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer
|
||||
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Other local types ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
|
||||
data Toolchain = Toolchain
|
||||
{ ghcVer :: Maybe GHCTargetVersion
|
||||
, cabalVer :: Maybe Version
|
||||
, hlsVer :: Maybe Version
|
||||
, stackVer :: Maybe Version
|
||||
} deriving Show
|
||||
@@ -1,344 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Set where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.Versions hiding ( str )
|
||||
import GHC.Unicode
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Bifunctor (second)
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data SetCommand = SetGHC SetOptions
|
||||
| SetCabal SetOptions
|
||||
| SetHLS SetOptions
|
||||
| SetStack SetOptions
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data SetOptions = SetOptions
|
||||
{ sToolVer :: SetToolVersion
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
setParser :: Parser (Either SetCommand SetOptions)
|
||||
setParser =
|
||||
(Left <$> subparser
|
||||
( command
|
||||
"ghc"
|
||||
( SetGHC
|
||||
<$> info
|
||||
(setOpts GHC <**> helper)
|
||||
( progDesc "Set GHC version"
|
||||
<> footerDoc (Just $ text setGHCFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( SetCabal
|
||||
<$> info
|
||||
(setOpts Cabal <**> helper)
|
||||
( progDesc "Set Cabal version"
|
||||
<> footerDoc (Just $ text setCabalFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( SetHLS
|
||||
<$> info
|
||||
(setOpts HLS <**> helper)
|
||||
( progDesc "Set haskell-language-server version"
|
||||
<> footerDoc (Just $ text setHLSFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( SetStack
|
||||
<$> info
|
||||
(setOpts Stack <**> helper)
|
||||
( progDesc "Set stack version"
|
||||
<> footerDoc (Just $ text setStackFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> setOpts GHC)
|
||||
where
|
||||
setGHCFooter :: String
|
||||
setGHCFooter = [s|Discussion:
|
||||
Sets the the current GHC version by creating non-versioned
|
||||
symlinks for all ghc binaries of the specified version in
|
||||
"~/.ghcup/bin/<binary>".|]
|
||||
|
||||
setCabalFooter :: String
|
||||
setCabalFooter = [s|Discussion:
|
||||
Sets the the current Cabal version.|]
|
||||
|
||||
setStackFooter :: String
|
||||
setStackFooter = [s|Discussion:
|
||||
Sets the the current Stack version.|]
|
||||
|
||||
setHLSFooter :: String
|
||||
setHLSFooter = [s|Discussion:
|
||||
Sets the the current haskell-language-server version.|]
|
||||
|
||||
|
||||
setOpts :: Tool -> Parser SetOptions
|
||||
setOpts tool = SetOptions <$>
|
||||
(fromMaybe SetRecommended <$>
|
||||
optional (setVersionArgument [ListInstalled True] tool))
|
||||
|
||||
setVersionArgument :: [ListCriteria] -> Tool -> Parser SetToolVersion
|
||||
setVersionArgument criteria tool =
|
||||
argument (eitherReader setEither)
|
||||
(metavar "VERSION|TAG|next"
|
||||
<> completer (tagCompleter tool ["next"])
|
||||
<> (completer . versionCompleter criteria) tool)
|
||||
where
|
||||
setEither s' =
|
||||
parseSet s'
|
||||
<|> second SetToolTag (tagEither s')
|
||||
<|> se s'
|
||||
se s' = case tool of
|
||||
GHC -> second SetGHCVersion (ghcVersionEither s')
|
||||
_ -> second SetToolVersion (toolVersionEither s')
|
||||
parseSet s' = case fmap toLower s' of
|
||||
"next" -> Right SetNext
|
||||
other -> Left $ "Unknown tag/version " <> other
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
setFooter :: String
|
||||
setFooter = [s|Discussion:
|
||||
Sets the currently active GHC or cabal version. When no command is given,
|
||||
defaults to setting GHC with the specified version/tag (if no tag
|
||||
is given, sets GHC to 'recommended' version).
|
||||
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type SetGHCEffects = '[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
|
||||
-> Excepts SetGHCEffects (ReaderT env m) a
|
||||
-> m (VEither SetGHCEffects a)
|
||||
runSetGHC runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@SetGHCEffects
|
||||
|
||||
|
||||
type SetCabalEffects = '[ NotInstalled
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
|
||||
-> Excepts SetCabalEffects (ReaderT env m) a
|
||||
-> m (VEither SetCabalEffects a)
|
||||
runSetCabal runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@SetCabalEffects
|
||||
|
||||
|
||||
type SetHLSEffects = '[ NotInstalled
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
|
||||
-> Excepts SetHLSEffects (ReaderT env m) a
|
||||
-> m (VEither SetHLSEffects a)
|
||||
runSetHLS runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@SetHLSEffects
|
||||
|
||||
|
||||
type SetStackEffects = '[ NotInstalled
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
|
||||
-> Excepts SetStackEffects (ReaderT env m) a
|
||||
-> m (VEither SetStackEffects a)
|
||||
runSetStack runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@SetStackEffects
|
||||
|
||||
|
||||
|
||||
-------------------
|
||||
--[ Entrypoints ]--
|
||||
-------------------
|
||||
|
||||
|
||||
set :: forall m env.
|
||||
( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
)
|
||||
=> Either SetCommand SetOptions
|
||||
-> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
|
||||
-> m (VEither eff GHCTargetVersion))
|
||||
-> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
|
||||
-> m (VEither eff GHCTargetVersion))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
set setCommand runAppState _ runLogger = case setCommand of
|
||||
(Right sopts) -> do
|
||||
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
|
||||
setGHC' sopts
|
||||
(Left (SetGHC sopts)) -> setGHC' sopts
|
||||
(Left (SetCabal sopts)) -> setCabal' sopts
|
||||
(Left (SetHLS sopts)) -> setHLS' sopts
|
||||
(Left (SetStack sopts)) -> setStack' sopts
|
||||
|
||||
where
|
||||
setGHC' :: SetOptions
|
||||
-> m ExitCode
|
||||
setGHC' SetOptions{ sToolVer } = runSetGHC runAppState (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
$ logInfo $
|
||||
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 5
|
||||
|
||||
|
||||
setCabal' :: SetOptions
|
||||
-> m ExitCode
|
||||
setCabal' SetOptions{ sToolVer } = runSetCabal runAppState (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
|
||||
liftE $ setCabal (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight v -> do
|
||||
runLogger
|
||||
$ logInfo $
|
||||
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
setHLS' :: SetOptions
|
||||
-> m ExitCode
|
||||
setHLS' SetOptions{ sToolVer } = runSetHLS runAppState (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight v -> do
|
||||
runLogger
|
||||
$ logInfo $
|
||||
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
|
||||
setStack' :: SetOptions
|
||||
-> m ExitCode
|
||||
setStack' SetOptions{ sToolVer } = runSetStack runAppState (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Stack
|
||||
liftE $ setStack (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight v -> do
|
||||
runLogger
|
||||
$ logInfo $
|
||||
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 14
|
||||
@@ -1,189 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.OptParse.Test where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Codec.Archive
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import URI.ByteString hiding ( uriParser )
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data TestCommand = TestGHC TestOptions
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data TestOptions = TestOptions
|
||||
{ testVer :: Maybe ToolVersion
|
||||
, testBindist :: Maybe URI
|
||||
, addMakeArgs :: [T.Text]
|
||||
}
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Footers ]--
|
||||
---------------
|
||||
|
||||
testFooter :: String
|
||||
testFooter = [s|Discussion:
|
||||
Runs test suites from the test bindist.|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
testParser :: Parser TestCommand
|
||||
testParser =
|
||||
subparser
|
||||
( command
|
||||
"ghc"
|
||||
( TestGHC
|
||||
<$> info
|
||||
(testOpts (Just GHC) <**> helper)
|
||||
( progDesc "Test GHC"
|
||||
<> footerDoc (Just $ text testGHCFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
where
|
||||
testGHCFooter :: String
|
||||
testGHCFooter = [s|Discussion:
|
||||
Runs the GHC test suite from the test bindist.|]
|
||||
|
||||
|
||||
testOpts :: Maybe Tool -> Parser TestOptions
|
||||
testOpts tool =
|
||||
(\(u, v) args -> TestOptions v u args)
|
||||
<$> ( ( (,)
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader uriParser)
|
||||
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
|
||||
"Install the specified version from this bindist"
|
||||
<> completer (toolDlCompleter (fromMaybe GHC tool))
|
||||
)
|
||||
)
|
||||
<*> (Just <$> toolVersionTagArgument [] tool)
|
||||
)
|
||||
<|> pure (Nothing, Nothing)
|
||||
)
|
||||
<*> many (argument str (metavar "MAKE_ARGS" <> help "Additional arguments to 'make', prefix with '-- ' (longopts)"))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type TestGHCEffects = [ DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, ArchiveResult
|
||||
, TarDirDoesNotExist
|
||||
, UnknownArchive
|
||||
, TestFailed
|
||||
, NextVerNotFound
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
runTestGHC :: AppState
|
||||
-> Excepts TestGHCEffects (ResourceT (ReaderT AppState IO)) a
|
||||
-> IO (VEither TestGHCEffects a)
|
||||
runTestGHC appstate' =
|
||||
flip runReaderT appstate'
|
||||
. runResourceT
|
||||
. runE
|
||||
@TestGHCEffects
|
||||
|
||||
|
||||
-------------------
|
||||
--[ Entrypoints ]--
|
||||
-------------------
|
||||
|
||||
|
||||
test :: TestCommand -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
|
||||
test testCommand settings getAppState' runLogger = case testCommand of
|
||||
(TestGHC iopts) -> go iopts
|
||||
where
|
||||
go :: TestOptions -> IO ExitCode
|
||||
go TestOptions{..} = do
|
||||
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
|
||||
(case testBindist of
|
||||
Nothing -> runTestGHC s' $ do
|
||||
(v, vi) <- liftE $ fromVersion testVer GHC
|
||||
liftE $ testGHCVer v addMakeArgs
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runTestGHC s'{ settings = settings {noVerify = True}} $ do
|
||||
(v, vi) <- liftE $ fromVersion testVer GHC
|
||||
liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) v addMakeArgs
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
runLogger $ logInfo "GHC test successful"
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
logError $ T.pack $ prettyHFError e
|
||||
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||
pure $ ExitFailure 3
|
||||
|
||||
@@ -1,121 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module GHCup.OptParse.ToolRequirements where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Platform
|
||||
import GHCup.Prelude
|
||||
import GHCup.Requirements
|
||||
import System.IO
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data ToolReqOpts = ToolReqOpts
|
||||
{ tlrRaw :: Bool
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
toolReqP :: Parser ToolReqOpts
|
||||
toolReqP =
|
||||
ToolReqOpts
|
||||
<$> switch (short 'r' <> long "raw-format" <> help "machine-parsable format")
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
toolReqFooter :: String
|
||||
toolReqFooter = [s|Discussion:
|
||||
Print tool requirements on the current platform.
|
||||
If you want to pass this to your package manage, use '--raw-format'.|]
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoToolRequirements ]
|
||||
|
||||
|
||||
runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a))
|
||||
-> Excepts ToolRequirementsEffects (ReaderT env m) a
|
||||
-> m (VEither ToolRequirementsEffects a)
|
||||
runToolRequirements runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@ToolRequirementsEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
toolRequirements :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, Alternative m
|
||||
)
|
||||
=> ToolReqOpts
|
||||
-> (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements runAppState (do
|
||||
GHCupInfo { .. } <- lift getGHCupInfo
|
||||
platform' <- liftE getPlatform
|
||||
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
|
||||
if tlrRaw
|
||||
then liftIO $ T.hPutStr stdout (rawRequirements req)
|
||||
else liftIO $ T.hPutStr stdout (prettyRequirements req)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 12
|
||||
@@ -1,212 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.UnSet where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data UnsetCommand = UnsetGHC UnsetOptions
|
||||
| UnsetCabal UnsetOptions
|
||||
| UnsetHLS UnsetOptions
|
||||
| UnsetStack UnsetOptions
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data UnsetOptions = UnsetOptions
|
||||
{ sToolVer :: Maybe T.Text -- target platform triple
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
unsetParser :: Parser UnsetCommand
|
||||
unsetParser =
|
||||
subparser
|
||||
( command
|
||||
"ghc"
|
||||
( UnsetGHC
|
||||
<$> info
|
||||
(unsetOpts <**> helper)
|
||||
( progDesc "Unset GHC version"
|
||||
<> footerDoc (Just $ text unsetGHCFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( UnsetCabal
|
||||
<$> info
|
||||
(unsetOpts <**> helper)
|
||||
( progDesc "Unset Cabal version"
|
||||
<> footerDoc (Just $ text unsetCabalFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( UnsetHLS
|
||||
<$> info
|
||||
(unsetOpts <**> helper)
|
||||
( progDesc "Unset haskell-language-server version"
|
||||
<> footerDoc (Just $ text unsetHLSFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( UnsetStack
|
||||
<$> info
|
||||
(unsetOpts <**> helper)
|
||||
( progDesc "Unset stack version"
|
||||
<> footerDoc (Just $ text unsetStackFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
where
|
||||
unsetGHCFooter :: String
|
||||
unsetGHCFooter = [s|Discussion:
|
||||
Unsets the the current GHC version. That means there won't
|
||||
be a ~/.ghcup/bin/ghc anymore.
|
||||
|
||||
Examples:
|
||||
# unset ghc
|
||||
ghcup unset ghc
|
||||
|
||||
# unset ghc for the target version
|
||||
ghcup unset ghc armv7-unknown-linux-gnueabihf|]
|
||||
|
||||
unsetCabalFooter :: String
|
||||
unsetCabalFooter = [s|Discussion:
|
||||
Unsets the the current Cabal version.|]
|
||||
|
||||
unsetStackFooter :: String
|
||||
unsetStackFooter = [s|Discussion:
|
||||
Unsets the the current Stack version.|]
|
||||
|
||||
unsetHLSFooter :: String
|
||||
unsetHLSFooter = [s|Discussion:
|
||||
Unsets the the current haskell-language-server version.|]
|
||||
|
||||
|
||||
unsetOpts :: Parser UnsetOptions
|
||||
unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE"))
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
unsetFooter :: String
|
||||
unsetFooter = [s|Discussion:
|
||||
Unsets the currently active GHC or cabal version.|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type UnsetEffects = '[ NotInstalled ]
|
||||
|
||||
|
||||
runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
|
||||
-> Excepts UnsetEffects (ReaderT env m) a
|
||||
-> m (VEither UnsetEffects a)
|
||||
runUnsetGHC runLeanAppState =
|
||||
runLeanAppState
|
||||
. runE
|
||||
@UnsetEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
unset :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
)
|
||||
=> UnsetCommand
|
||||
-> (ReaderT env m (VEither UnsetEffects ())
|
||||
-> m (VEither UnsetEffects ()))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
unset unsetCommand runLeanAppState runLogger = case unsetCommand of
|
||||
(UnsetGHC (UnsetOptions triple)) -> runUnsetGHC runLeanAppState (unsetGHC triple)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
runLogger $ logInfo "GHC successfully unset"
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 14
|
||||
(UnsetCabal (UnsetOptions _)) -> do
|
||||
void $ runLeanAppState (VRight <$> unsetCabal)
|
||||
runLogger $ logInfo "Cabal successfully unset"
|
||||
pure ExitSuccess
|
||||
(UnsetHLS (UnsetOptions _)) -> do
|
||||
void $ runLeanAppState (VRight <$> unsetHLS)
|
||||
runLogger $ logInfo "HLS successfully unset"
|
||||
pure ExitSuccess
|
||||
(UnsetStack (UnsetOptions _)) -> do
|
||||
void $ runLeanAppState (VRight <$> unsetStack)
|
||||
runLogger $ logInfo "Stack successfully unset"
|
||||
pure ExitSuccess
|
||||
@@ -1,155 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Upgrade where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import System.Environment
|
||||
import GHCup.Utils
|
||||
import System.FilePath
|
||||
import GHCup.Types.Optics
|
||||
import Data.Versions hiding (str)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data UpgradeOpts = UpgradeInplace
|
||||
| UpgradeAt FilePath
|
||||
| UpgradeGHCupDir
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
upgradeOptsP :: Parser UpgradeOpts
|
||||
upgradeOptsP =
|
||||
flag'
|
||||
UpgradeInplace
|
||||
(short 'i' <> long "inplace" <> help
|
||||
"Upgrade ghcup in-place"
|
||||
)
|
||||
<|>
|
||||
( UpgradeAt
|
||||
<$> option
|
||||
str
|
||||
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
|
||||
"Absolute filepath to write ghcup into"
|
||||
<> completer (bashCompleter "file")
|
||||
)
|
||||
)
|
||||
<|> pure UpgradeGHCupDir
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type UpgradeEffects = '[ DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, NoDownload
|
||||
, NoUpdate
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, DownloadFailed
|
||||
, ToolShadowed
|
||||
]
|
||||
|
||||
|
||||
runUpgrade :: MonadUnliftIO m
|
||||
=> (ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
|
||||
-> Excepts UpgradeEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither UpgradeEffects a)
|
||||
runUpgrade runAppState =
|
||||
runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@UpgradeEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
upgrade :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> UpgradeOpts
|
||||
-> Bool
|
||||
-> Bool
|
||||
-> Dirs
|
||||
-> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> Just <$> liftIO getExecutablePath
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
|
||||
|
||||
runUpgrade runAppState (do
|
||||
v' <- liftE $ upgradeGHCup target force' fatal
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (v', dls)
|
||||
) >>= \case
|
||||
VRight (v', dls) -> do
|
||||
let pretty_v = prettyVer v'
|
||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||
runLogger $ logInfo $
|
||||
"Successfully upgraded GHCup to version " <> pretty_v
|
||||
forM_ (_viPostInstall vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft (V NoUpdate) -> do
|
||||
runLogger $ logWarn "No GHCup update available"
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 11
|
||||
@@ -1,343 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module GHCup.OptParse.Whereis where
|
||||
|
||||
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import System.FilePath (takeDirectory)
|
||||
import GHCup.Types.Optics
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Commands ]--
|
||||
----------------
|
||||
|
||||
|
||||
data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
|
||||
| WhereisBaseDir
|
||||
| WhereisBinDir
|
||||
| WhereisCacheDir
|
||||
| WhereisLogsDir
|
||||
| WhereisConfDir
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
|
||||
data WhereisOptions = WhereisOptions {
|
||||
directory :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
whereisP :: Parser WhereisCommand
|
||||
whereisP = subparser
|
||||
(commandGroup "Tools locations:" <>
|
||||
command
|
||||
"ghc"
|
||||
(WhereisTool GHC <$> info
|
||||
( optional (toolVersionTagArgument [] (Just GHC)) <**> helper )
|
||||
( progDesc "Get GHC location"
|
||||
<> footerDoc (Just $ text whereisGHCFooter ))
|
||||
)
|
||||
<>
|
||||
command
|
||||
"cabal"
|
||||
(WhereisTool Cabal <$> info
|
||||
( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper )
|
||||
( progDesc "Get cabal location"
|
||||
<> footerDoc (Just $ text whereisCabalFooter ))
|
||||
)
|
||||
<>
|
||||
command
|
||||
"hls"
|
||||
(WhereisTool HLS <$> info
|
||||
( optional (toolVersionTagArgument [] (Just HLS)) <**> helper )
|
||||
( progDesc "Get HLS location"
|
||||
<> footerDoc (Just $ text whereisHLSFooter ))
|
||||
)
|
||||
<>
|
||||
command
|
||||
"stack"
|
||||
(WhereisTool Stack <$> info
|
||||
( optional (toolVersionTagArgument [] (Just Stack)) <**> helper )
|
||||
( progDesc "Get stack location"
|
||||
<> footerDoc (Just $ text whereisStackFooter ))
|
||||
)
|
||||
<>
|
||||
command
|
||||
"ghcup"
|
||||
(WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
|
||||
) <|> subparser ( commandGroup "Directory locations:"
|
||||
<>
|
||||
command
|
||||
"basedir"
|
||||
(info (pure WhereisBaseDir <**> helper)
|
||||
( progDesc "Get ghcup base directory location" )
|
||||
)
|
||||
<>
|
||||
command
|
||||
"bindir"
|
||||
(info (pure WhereisBinDir <**> helper)
|
||||
( progDesc "Get ghcup binary directory location" )
|
||||
)
|
||||
<>
|
||||
command
|
||||
"cachedir"
|
||||
(info (pure WhereisCacheDir <**> helper)
|
||||
( progDesc "Get ghcup cache directory location" )
|
||||
)
|
||||
<>
|
||||
command
|
||||
"logsdir"
|
||||
(info (pure WhereisLogsDir <**> helper)
|
||||
( progDesc "Get ghcup logs directory location" )
|
||||
)
|
||||
<>
|
||||
command
|
||||
"confdir"
|
||||
(info (pure WhereisConfDir <**> helper)
|
||||
( progDesc "Get ghcup config directory location" )
|
||||
)
|
||||
)
|
||||
where
|
||||
whereisGHCFooter = [s|Discussion:
|
||||
Finds the location of a GHC executable, which usually resides in
|
||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory.
|
||||
|
||||
Examples:
|
||||
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
|
||||
ghcup whereis ghc 8.10.5
|
||||
# outputs ~/.ghcup/ghc/8.10.5/bin/
|
||||
ghcup whereis --directory ghc 8.10.5 |]
|
||||
|
||||
whereisCabalFooter = [s|Discussion:
|
||||
Finds the location of a Cabal executable, which usually resides in
|
||||
"~/.ghcup/bin/".
|
||||
|
||||
Examples:
|
||||
# outputs ~/.ghcup/bin/cabal-3.4.0.0
|
||||
ghcup whereis cabal 3.4.0.0
|
||||
# outputs ~/.ghcup/bin
|
||||
ghcup whereis --directory cabal 3.4.0.0|]
|
||||
|
||||
whereisHLSFooter = [s|Discussion:
|
||||
Finds the location of a HLS executable, which usually resides in
|
||||
"~/.ghcup/bin/".
|
||||
|
||||
Examples:
|
||||
# outputs ~/.ghcup/bin/haskell-language-server-wrapper-1.2.0
|
||||
ghcup whereis hls 1.2.0
|
||||
# outputs ~/.ghcup/bin/
|
||||
ghcup whereis --directory hls 1.2.0|]
|
||||
|
||||
whereisStackFooter = [s|Discussion:
|
||||
Finds the location of a stack executable, which usually resides in
|
||||
"~/.ghcup/bin/".
|
||||
|
||||
Examples:
|
||||
# outputs ~/.ghcup/bin/stack-2.7.1
|
||||
ghcup whereis stack 2.7.1
|
||||
# outputs ~/.ghcup/bin/
|
||||
ghcup whereis --directory stack 2.7.1|]
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Footer ]--
|
||||
--------------
|
||||
|
||||
|
||||
whereisFooter :: String
|
||||
whereisFooter = [s|Discussion:
|
||||
Finds the location of a tool. For GHC, this is the ghc binary, that
|
||||
usually resides in a self-contained "~/.ghcup/ghc/<ghcver>" directory.
|
||||
For cabal/stack/hls this the binary usually at "~/.ghcup/bin/<tool>-<ver>".
|
||||
|
||||
Examples:
|
||||
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
|
||||
ghcup whereis ghc 8.10.5
|
||||
# outputs ~/.ghcup/ghc/8.10.5/bin/
|
||||
ghcup whereis --directory ghc 8.10.5
|
||||
# outputs ~/.ghcup/bin/cabal-3.4.0.0
|
||||
ghcup whereis cabal 3.4.0.0
|
||||
# outputs ~/.ghcup/bin/
|
||||
ghcup whereis --directory cabal 3.4.0.0|]
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Effect interpreters ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
type WhereisEffects = '[ NotInstalled
|
||||
, NoToolVersionSet
|
||||
, NextVerNotFound
|
||||
, TagNotFound
|
||||
, DayNotFound
|
||||
]
|
||||
|
||||
|
||||
runLeanWhereIs :: (MonadUnliftIO m, MonadIO m)
|
||||
=> LeanAppState
|
||||
-> Excepts WhereisEffects (ReaderT LeanAppState m) a
|
||||
-> m (VEither WhereisEffects a)
|
||||
runLeanWhereIs leanAppstate =
|
||||
-- Don't use runLeanAppState here, which is disabled on windows.
|
||||
-- This is the only command on all platforms that doesn't need full appstate.
|
||||
flip runReaderT leanAppstate
|
||||
. runE
|
||||
@WhereisEffects
|
||||
|
||||
|
||||
runWhereIs :: (MonadUnliftIO m, MonadIO m)
|
||||
=> (ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
|
||||
-> Excepts WhereisEffects (ReaderT AppState m) a
|
||||
-> m (VEither WhereisEffects a)
|
||||
runWhereIs runAppState =
|
||||
runAppState
|
||||
. runE
|
||||
@WhereisEffects
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Entrypoint ]--
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
whereis :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> WhereisCommand
|
||||
-> WhereisOptions
|
||||
-> (forall a. ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
|
||||
-> LeanAppState
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
|
||||
Dirs{ .. } <- runReaderT getDirs leanAppstate
|
||||
case (whereisCommand, whereisOptions) of
|
||||
(WhereisTool GHCup _, WhereisOptions{..}) -> do
|
||||
loc <- liftIO (getExecutablePath >>= canonicalizePath )
|
||||
if directory
|
||||
then liftIO $ putStr $ takeDirectory loc
|
||||
else liftIO $ putStr loc
|
||||
pure ExitSuccess
|
||||
|
||||
(WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) ->
|
||||
runLeanWhereIs leanAppstate (do
|
||||
loc <- liftE $ whereIsTool tool v
|
||||
if directory
|
||||
then pure $ takeDirectory loc
|
||||
else pure loc
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> do
|
||||
liftIO $ putStr r
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 30
|
||||
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
|
||||
runLeanWhereIs leanAppstate (do
|
||||
loc <- liftE $ whereIsTool tool (mkTVer v)
|
||||
if directory
|
||||
then pure $ takeDirectory loc
|
||||
else pure loc
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> do
|
||||
liftIO $ putStr r
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
|
||||
runWhereIs runAppState (do
|
||||
(v, _) <- liftE $ fromVersion whereVer tool
|
||||
loc <- liftE $ whereIsTool tool v
|
||||
if directory
|
||||
then pure $ takeDirectory loc
|
||||
else pure loc
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> do
|
||||
liftIO $ putStr r
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyHFError e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
(WhereisBaseDir, _) -> do
|
||||
liftIO $ putStr $ fromGHCupPath baseDir
|
||||
pure ExitSuccess
|
||||
|
||||
(WhereisBinDir, _) -> do
|
||||
liftIO $ putStr binDir
|
||||
pure ExitSuccess
|
||||
|
||||
(WhereisCacheDir, _) -> do
|
||||
liftIO $ putStr $ fromGHCupPath cacheDir
|
||||
pure ExitSuccess
|
||||
|
||||
(WhereisLogsDir, _) -> do
|
||||
liftIO $ putStr $ fromGHCupPath logsDir
|
||||
pure ExitSuccess
|
||||
|
||||
(WhereisConfDir, _) -> do
|
||||
liftIO $ putStr $ fromGHCupPath confDir
|
||||
pure ExitSuccess
|
||||
Reference in New Issue
Block a user