Refactor app Main

This commit is contained in:
Julian Ospald 2021-10-15 22:24:23 +02:00
parent 09d2a1e815
commit 01956d694d
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
24 changed files with 4370 additions and 2880 deletions

2
.gitignore vendored
View File

@ -13,3 +13,5 @@ TAGS
/tmp/ /tmp/
.entangled .entangled
release/ release/
releases/
site/

View File

@ -15,5 +15,5 @@ git describe
ecabal update ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
hlint -r lib/ test/ hlint -r app/ lib/ test/

View File

@ -1,10 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}

View File

@ -91,23 +91,23 @@ validate dls _ = do
checkHasRequiredPlatforms t v tags arch pspecs = do checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v let v' = prettyVer v
arch' = prettyShow arch arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do when (Linux UnknownLinux `notElem` pspecs) $ do
lift $ logError $ lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError addError
when ((notElem Darwin pspecs) && arch == A_64) $ do when ((Darwin `notElem` pspecs) && arch == A_64) $ do
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError addError
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $ when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (notElem Windows pspecs && arch == A_64) $ do when (Windows `notElem` pspecs && arch == A_64) $ do
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError addError
-- alpine needs to be set explicitly, because -- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine -- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static) -- (although it could be static)
when (notElem (Linux Alpine) pspecs) $ when (Linux Alpine `notElem` pspecs) $
case t of case t of
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
Cabal | v > [vver|2.4.1.0|] Cabal | v > [vver|2.4.1.0|]
@ -117,7 +117,7 @@ validate dls _ = do
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch) _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do checkUniqueTags tool = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
let nonUnique = let nonUnique =
fmap fst fmap fst
. filter (\(_, b) -> not b) . filter (\(_, b) -> not b)
@ -155,8 +155,8 @@ validate dls _ = do
-- a tool must have at least one of each mandatory tags -- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do checkMandatoryTags tool = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
forM_ [Latest, Recommended] $ \t -> case elem t allTags of forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
False -> do False -> do
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool) lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError addError
@ -202,7 +202,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError) when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
forM_ allDls (downloadAll ref) forM_ allDls (downloadAll ref)
-- exit -- exit
@ -260,7 +260,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
when (basePath /= prel) $ do when (basePath /= prel) $ do
logError $ logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
(flip runReaderT ref addError) runReaderT addError ref
Just (RegexDir regexString) -> do Just (RegexDir regexString) -> do
logInfo $ logInfo $
"verifying subdir (regex): " <> T.pack regexString "verifying subdir (regex): " <> T.pack regexString
@ -268,13 +268,13 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
compIgnoreCase compIgnoreCase
execBlank execBlank
regexString regexString
when (not (match regex basePath)) $ do unless (match regex basePath) $ do
logError $ logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
(flip runReaderT ref addError) runReaderT addError ref
Nothing -> pure () Nothing -> pure ()
VRight Nothing -> pure () VRight Nothing -> pure ()
VLeft e -> do VLeft e -> do
logError $ logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e) "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
(flip runReaderT ref addError) runReaderT addError ref

View File

@ -2,10 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
module BrickMain where module BrickMain where
@ -368,10 +365,7 @@ listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int selectLatest :: Vector ListResult -> Int
selectLatest v = selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
Just ix -> ix
Nothing -> 0
-- | Replace the @appState@ or construct it based on a filter function -- | Replace the @appState@ or construct it based on a filter function
@ -398,14 +392,14 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True filterVisible v t e | lInstalled e = True
| v | v
, not t , not t
, not (elem (lTool e) hiddenTools) = True , lTool e `notElem` hiddenTools = True
| not v | not v
, t , t
, not (elem Old (lTag e)) = True , Old `notElem` lTag e = True
| v | v
, t = True , t = True
| otherwise = not (elem Old (lTag e)) && | otherwise = (Old `notElem` lTag e) &&
not (elem (lTool e) hiddenTools) (lTool e `notElem` hiddenTools)
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
@ -507,7 +501,7 @@ del' _ (_, ListResult {..}) = do
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg -> forM_ (_viPostRemove =<< vi) $ \msg ->
logInfo msg logInfo msg
pure $ Right () pure $ Right ()
VLeft e -> pure $ Left (prettyShow e) VLeft e -> pure $ Left (prettyShow e)
@ -594,8 +588,7 @@ getGHCupInfo = do
r <- r <-
flip runReaderT settings flip runReaderT settings
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE $ liftE getDownloadsF
$ getDownloadsF
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a

303
app/ghcup/GHCup/OptParse.hs Normal file
View File

@ -0,0 +1,303 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module GHCup.OptParse (
module GHCup.OptParse.Common
, module GHCup.OptParse.Install
, module GHCup.OptParse.Set
, module GHCup.OptParse.UnSet
, module GHCup.OptParse.Rm
, module GHCup.OptParse.Compile
, module GHCup.OptParse.Config
, module GHCup.OptParse.Whereis
, module GHCup.OptParse.List
, module GHCup.OptParse.Upgrade
, module GHCup.OptParse.ChangeLog
, module GHCup.OptParse.Prefetch
, module GHCup.OptParse.GC
, module GHCup.OptParse.DInfo
, module GHCup.OptParse.Nuke
, module GHCup.OptParse.ToolRequirements
, module GHCup.OptParse
) where
import GHCup.OptParse.Common
import GHCup.OptParse.Install
import GHCup.OptParse.Set
import GHCup.OptParse.UnSet
import GHCup.OptParse.Rm
import GHCup.OptParse.Compile
import GHCup.OptParse.Config
import GHCup.OptParse.Whereis
import GHCup.OptParse.List
import GHCup.OptParse.Upgrade
import GHCup.OptParse.ChangeLog
import GHCup.OptParse.Prefetch
import GHCup.OptParse.GC
import GHCup.OptParse.DInfo
import GHCup.OptParse.ToolRequirements
import GHCup.OptParse.Nuke
import GHCup.Types
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Bifunctor
import Data.Either
import Data.Functor
import Data.Maybe
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
data Options = Options
{
-- global options
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
, optGpg :: Maybe GPGSetting
-- commands
, optCommand :: Command
}
data Command
= Install (Either InstallCommand InstallOptions)
| InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions)
| UnSet UnsetCommand
| List ListOptions
| Rm (Either RmCommand RmOptions)
| DInfo
| Compile CompileCommand
| Config ConfigCommand
| Whereis WhereisOptions WhereisCommand
| Upgrade UpgradeOpts Bool
| ToolRequirements
| ChangeLog ChangeLogOptions
| Nuke
#if defined(BRICK)
| Interactive
#endif
| Prefetch PrefetchCommand
| GC GCOptions
opts :: Parser Options
opts =
Options
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
<*> optional
(option
(eitherReader parseUri)
( short 's'
<> long "url-source"
<> metavar "URL"
<> help "Alternative ghcup download info url"
<> internal
)
)
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
<*> optional (option
(eitherReader keepOnParser)
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories? (default: errors)"
<> hidden
))
<*> optional (option
(eitherReader downloaderParser)
( long "downloader"
#if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>"
<> help
"Downloader to use (default: internal)"
#else
<> metavar "<curl|wget>"
<> help
"Downloader to use (default: curl)"
#endif
<> hidden
))
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
<*> optional (option
(eitherReader gpgParser)
( long "gpg"
<> metavar "<strict|lax|none>"
<> help
"GPG verification (default: none)"
))
<*> com
where
parseUri s' =
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command
com =
subparser
#if defined(BRICK)
( command
"tui"
( (\_ -> Interactive)
<$> info
helper
( progDesc "Start the interactive GHCup UI"
)
)
<> command
#else
( command
#endif
"install"
( Install
<$> info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal/HLS/stack"
<> footerDoc (Just $ text installToolFooter)
)
)
<> command
"set"
(info
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
<> command
"unset"
(info
(UnSet <$> unsetParser <**> helper)
( progDesc "Unset currently active GHC/cabal version"
<> footerDoc (Just $ text unsetFooter)
)
)
<> command
"rm"
(info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal/HLS/stack version"
<> footerDoc (Just $ text rmFooter)
)
)
<> command
"list"
(info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
<> command
"upgrade"
(info
( (Upgrade <$> upgradeOptsP <*> switch
(short 'f' <> long "force" <> help "Force update")
)
<**> helper
)
(progDesc "Upgrade ghcup")
)
<> command
"compile"
( Compile
<$> info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
<> command
"whereis"
(info
( (Whereis
<$> (WhereisOptions <$> switch (short 'd' <> long "directory" <> help "return directory of the binary instead of the binary location"))
<*> whereisP
) <**> helper
)
(progDesc "Find a tools location"
<> footerDoc ( Just $ text whereisFooter ))
)
<> command
"prefetch"
(info
( (Prefetch
<$> prefetchP
) <**> helper
)
(progDesc "Prefetch assets"
<> footerDoc ( Just $ text prefetchFooter ))
)
<> command
"gc"
(info
( (GC
<$> gcP
) <**> helper
)
(progDesc "Garbage collection"
<> footerDoc ( Just $ text gcFooter ))
)
<> commandGroup "Main commands:"
)
<|> subparser
( command
"debug-info"
((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
<> command
"tool-requirements"
( (\_ -> ToolRequirements)
<$> info helper
(progDesc "Show the requirements for ghc/cabal")
)
<> command
"changelog"
(info
(fmap ChangeLog changelogP <**> helper)
( progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
)
<> command
"config"
( Config
<$> info (configP <**> helper)
(progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
)
<> commandGroup "Other commands:"
<> hidden
)
<|> subparser
( command
"install-cabal"
(info
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
<> internal
)
<|> subparser
(command
"nuke"
(info (pure Nuke <**> helper)
(progDesc "Completely remove ghcup from your system"))
<> commandGroup "Nuclear Commands:"
<> hidden
)

View File

@ -0,0 +1,150 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.ChangeLog where
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
import GHCup.Utils
import Data.Versions
import URI.ByteString (serializeURIRef')
import GHCup.Utils.Prelude
import GHCup.Utils.File (exec)
import Data.Char (toLower)
---------------
--[ Options ]--
---------------
data ChangeLogOptions = ChangeLogOptions
{ clOpen :: Bool
, clTool :: Maybe Tool
, clToolVer :: Maybe ToolVersion
}
---------------
--[ Parsers ]--
---------------
changelogP :: Parser ChangeLogOptions
changelogP =
(\x y -> ChangeLogOptions x y)
<$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
<*> optional
(option
(eitherReader
(\s' -> case fmap toLower s' of
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
"stack" -> Right Stack
e -> Left e
)
)
(short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)"
)
)
<*> optional (toolVersionArgument Nothing Nothing)
--------------
--[ Footer ]--
--------------
changeLogFooter :: String
changeLogFooter = [s|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
------------------
--[ Entrypoint ]--
------------------
changelog :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> ChangeLogOptions
-> (forall a . ReaderT AppState m a -> m a)
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
changelog ChangeLogOptions{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool
ver' = maybe
(Right Latest)
(\case
ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion
ToolTag t -> Right t
)
clToolVer
muri = getChangeLog dls tool ver'
case muri of
Nothing -> do
runLogger
(logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
)
pure ExitSuccess
Just uri -> do
pfreq <- runAppState getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
if clOpen
then do
runAppState $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13)
else liftIO $ putStrLn uri' >> pure ExitSuccess

View File

@ -0,0 +1,513 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module GHCup.OptParse.Common where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.Functor
import Data.List ( nub, sort, sortBy )
import Data.Maybe
import Data.Text ( Text )
import Data.Versions hiding ( str )
import Data.Void
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import Safe
import System.FilePath
import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
import GHCup.Version
-------------
--[ Types ]--
-------------
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag
-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
| SetToolTag Tag
| SetRecommended
| SetNext
prettyToolVer :: ToolVersion -> String
prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolTag t) = show t
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer Nothing = SetRecommended
--------------
--[ Parser ]--
--------------
-- | same as toolVersionParser, except as an argument.
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument criteria tool =
argument (eitherReader toolVersionEither)
(metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
where
mv (Just GHC) = "GHC_VERSION|TAG"
mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG"
versionParser :: Parser GHCTargetVersion
versionParser = option
(eitherReader tVersionEither)
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
-- https://github.com/pcapriotti/optparse-applicative/issues/148
-- | A switch that can be enabled using --foo and disabled using --no-foo.
--
-- The option modifier is applied to only the option that is *not* enabled
-- by default. For example:
--
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
--
-- This example makes --recursive enabled by default, so
-- the help is shown only for --no-recursive.
invertableSwitch
:: String -- ^ long option
-> Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier
-> Parser (Maybe Bool)
invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv
(if defv then mempty else optmod)
(if defv then optmod else mempty)
-- | Allows providing option modifiers for both --foo and --no-foo.
invertableSwitch'
:: String -- ^ long option (eg "foo")
-> Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier for --foo
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
-> Parser (Maybe Bool)
invertableSwitch' longopt shortopt defv enmod dismod = optional
( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt)
<|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)
)
where
nolongopt = "no-" ++ longopt
---------------------
--[ Either Parser ]--
---------------------
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
Right r -> pure r
Left e -> Left $ errorBundlePretty e
where
archP :: MP.Parsec Void Text Architecture
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
platformP :: MP.Parsec Void Text PlatformRequest
platformP = choice'
[ (`PlatformRequest` FreeBSD)
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "portbld"
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
<|> pure Nothing
)
<* MP.chunk "-freebsd"
)
, (`PlatformRequest` Darwin)
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "apple"
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
<|> pure Nothing
)
<* MP.chunk "-darwin"
)
, (\a d mv -> PlatformRequest a (Linux d) mv)
<$> (archP <* MP.chunk "-")
<*> distroP
<*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
)
<* MP.chunk "-linux"
)
]
distroP :: MP.Parsec Void Text LinuxDistro
distroP = choice'
[ MP.chunk "debian" $> Debian
, MP.chunk "deb" $> Debian
, MP.chunk "ubuntu" $> Ubuntu
, MP.chunk "mint" $> Mint
, MP.chunk "fedora" $> Fedora
, MP.chunk "centos" $> CentOS
, MP.chunk "redhat" $> RedHat
, MP.chunk "alpine" $> Alpine
, MP.chunk "gentoo" $> Gentoo
, MP.chunk "exherbo" $> Exherbo
, MP.chunk "unknown" $> UnknownLinux
]
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
absolutePathParser :: FilePath -> Either String FilePath
absolutePathParser f = case isValid f && isAbsolute f of
True -> Right $ normalise f
False -> Left "Please enter a valid absolute filepath."
isolateParser :: FilePath -> Either String FilePath
isolateParser f = case isValid f of
True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir."
toolVersionEither :: String -> Either String ToolVersion
toolVersionEither s' =
second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x)
Left _ -> Left $ "Invalid PVP version for base " <> ver'
other -> Left $ "Unknown tag " <> other
tVersionEither :: String -> Either String GHCTargetVersion
tVersionEither =
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
toolParser :: String -> Either String Tool
toolParser s' | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal
| t == T.pack "hls" = Right HLS
| t == T.pack "stack" = Right Stack
| otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s')
criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| t == T.pack "available" = Right ListAvailable
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s')
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP' <|> toolP
where
verP' = ToolVersion <$> versionParser
toolP =
ToolTag
<$> option
(eitherReader tagEither)
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
keepOnParser :: String -> Either String KeepDirs
keepOnParser s' | t == T.pack "always" = Right Always
| t == T.pack "errors" = Right Errors
| t == T.pack "never" = Right Never
| otherwise = Left ("Unknown keep value: " <> s')
where t = T.toLower (T.pack s')
downloaderParser :: String -> Either String Downloader
downloaderParser s' | t == T.pack "curl" = Right Curl
| t == T.pack "wget" = Right Wget
#if defined(INTERNAL_DOWNLOADER)
| t == T.pack "internal" = Right Internal
#endif
| otherwise = Left ("Unknown downloader value: " <> s')
where t = T.toLower (T.pack s')
gpgParser :: String -> Either String GPGSetting
gpgParser s' | t == T.pack "strict" = Right GPGStrict
| t == T.pack "lax" = Right GPGLax
| t == T.pack "none" = Right GPGNone
| otherwise = Left ("Unknown gpg setting value: " <> s')
where t = T.toLower (T.pack s')
------------------
--[ Completers ]--
------------------
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True GPGNone False)
dirs'
defaultKeyBindings
loggerConfig
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let settings = Settings True False Never Curl False GHCupURL True GPGNone False
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
settings
dirs'
defaultKeyBindings
ghcupInfo
pfreq
loggerConfig
runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ T.unpack . prettyVer . lVer <$> installedVersions
-----------------
--[ Utilities ]--
-----------------
fromVersion :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Maybe ToolVersion
-> Tool
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> SetToolVersion
-> Tool
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool
?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi)
Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of
GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
ghcs <- rights <$> lift getInstalledGHCs
(headMay
. tail
. dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
. cycle
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
. filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
$ ghcs) ?? NoToolVersionSet tool
Cabal -> do
set <- cabalSet !? NoToolVersionSet tool
cabals <- rights <$> lift getInstalledCabals
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ cabals) ?? NoToolVersionSet tool
HLS -> do
set <- hlsSet !? NoToolVersionSet tool
hlses <- rights <$> lift getInstalledHLSs
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ hlses) ?? NoToolVersionSet tool
Stack -> do
set <- stackSet !? NoToolVersionSet tool
stacks <- rights <$> lift getInstalledStacks
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls
pure (next, vi)
fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool
checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadFail m
)
=> m ()
checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ logWarn $
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
forM_ (getLatest dls GHC) $ \(l, _) -> do
let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ logWarn $
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
forM_ (getLatest dls Cabal) $ \(l, _) -> do
let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ logWarn $
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
forM_ (getLatest dls HLS) $ \(l, _) -> do
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver ->
when (l > hls_ver)
$ logWarn $
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver ->
when (l > stack_ver)
$ logWarn $
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"

View File

@ -0,0 +1,517 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Compile where
import GHCup
import GHCup.Errors
import GHCup.Utils.File
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Codec.Archive ( ArchiveResult )
import Control.Concurrent (threadDelay)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.Functor
import Data.Maybe
import Data.Versions ( Version, prettyVer, version )
import Data.Text ( Text )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import System.FilePath (isPathSeparator)
import Text.Read (readEither)
----------------
--[ Commands ]--
----------------
data CompileCommand = CompileGHC GHCCompileOptions
| CompileHLS HLSCompileOptions
---------------
--[ Options ]--
---------------
data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: Either Version GitBranch
, bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int
, buildConfig :: Maybe FilePath
, patchDir :: Maybe FilePath
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
, setCompile :: Bool
, ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String
, hadrian :: Bool
, isolateDir :: Maybe FilePath
}
data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: Either Version GitBranch
, jobs :: Maybe Int
, setCompile :: Bool
, ovewrwiteVer :: Maybe Version
, isolateDir :: Maybe FilePath
, cabalProject :: Maybe FilePath
, cabalProjectLocal :: Maybe FilePath
, patchDir :: Maybe FilePath
, targetGHCs :: [ToolVersion]
}
---------------
--[ Parsers ]--
---------------
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
<$> info
(ghcCompileOpts <**> helper)
( progDesc "Compile GHC from source"
<> footerDoc (Just $ text compileFooter)
)
)
<> command
"hls"
( CompileHLS
<$> info
(hlsCompileOpts <**> helper)
( progDesc "Compile HLS from source"
<> footerDoc (Just $ text compileHLSFooter)
)
)
)
where
compileFooter = [s|Discussion:
Compiles and installs the specified GHC version into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
This also allows building a cross-compiler. Consult the documentation
first: <https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#configuring-the-build>
ENV variables:
Various toolchain variables will be passed onto the ghc build system,
such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
Examples:
# compile from known version
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
# compile from git commit/reference
ghcup compile ghc -j 4 -g master -b 8.2.2
# specify path to bootstrap ghc
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
# build cross compiler
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
compileHLSFooter = [s|Discussion:
Compiles and installs the specified HLS version.
The last argument is a list of GHC versions to compile for.
These need to be available in PATH prior to compilation.
Examples:
ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|]
ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts =
GHCCompileOptions
<$> ((Left <$> option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
) <|>
(Right <$> (GitBranch <$> option
str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from"
) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
)))
<*> option
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
)
)
( short 'b'
<> long "bootstrap-ghc"
<> metavar "BOOTSTRAP_GHC"
<> help
"The GHC version (or full path) to bootstrap with (must be installed)"
)
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
)
)
<*> optional
(option
str
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
)
)
<*> optional
(option
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
)
<*> optional
(option
str
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
"Build cross-compiler for this platform"
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
)
)
<*> optional
(option
str
(short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
"Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
)
)
<*> switch
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
)
)
hlsCompileOpts :: Parser HLSCompileOptions
hlsCompileOpts =
HLSCompileOptions
<$> ((Left <$> option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
) <|>
(Right <$> (GitBranch <$> option
str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from"
) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
)))
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
)
)
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
)
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
)
)
<*> optional
(option
str
(long "cabal-project" <> metavar "CABAL_PROJECT" <> help
"If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
)
)
<*> optional
(option
(eitherReader absolutePathParser)
(long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
"Absolute path to a cabal.project.local to be used for the build. Will be copied over."
)
)
<*> optional
(option
(eitherReader absolutePathParser)
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
)
<*> some (toolVersionArgument Nothing (Just GHC))
---------------------------
--[ Effect interpreters ]--
---------------------------
type GHCEffects = '[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
]
type HLSEffects = '[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
, NotInstalled
, DirNotEmpty
, ArchiveResult
]
runCompileGHC :: (MonadUnliftIO m, MonadIO m)
=> (ReaderT AppState m (VEither GHCEffects a) -> m (VEither GHCEffects a))
-> Excepts GHCEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither GHCEffects a)
runCompileGHC runAppState =
runAppState
. runResourceT
. runE
@GHCEffects
runCompileHLS :: (MonadUnliftIO m, MonadIO m)
=> (ReaderT AppState m (VEither HLSEffects a) -> m (VEither HLSEffects a))
-> Excepts HLSEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither HLSEffects a)
runCompileHLS runAppState =
runAppState
. runResourceT
. runE
@HLSEffects
------------------
--[ Entrypoint ]--
------------------
compile :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> CompileCommand
-> Settings
-> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
compile compileCommand settings runAppState runLogger = do
VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)
case compileCommand of
(CompileHLS HLSCompileOptions { .. }) -> do
runCompileHLS runAppState (do
case targetHLS of
Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
targetVer <- liftE $ compileHLS
targetHLS
ghcs
jobs
ovewrwiteVer
isolateDir
cabalProject
cabalProjectLocal
patchDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $
setHLS targetVer
pure (vi, targetVer)
)
>>= \case
VRight (vi, tv) -> do
runLogger $ logInfo
"HLS successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
liftIO $ putStr (T.unpack $ prettyVer tv)
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do
case targetGhc of
Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
targetVer <- liftE $ compileGHC
(first (GHCTargetVersion crossTarget) targetGhc)
ovewrwiteVer
bootstrapGhc
jobs
buildConfig
patchDir
addConfArgs
buildFlavour
hadrian
isolateDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly
pure (vi, targetVer)
)
>>= \case
VRight (vi, tv) -> do
runLogger $ logInfo
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
liftIO $ putStr (T.unpack $ tVerToText tv)
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9

View File

@ -0,0 +1,168 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Config where
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.YAML.Aeson as Y
import Control.Exception.Safe (MonadMask)
----------------
--[ Commands ]--
----------------
data ConfigCommand
= ShowConfig
| SetConfig String String
| InitConfig
---------------
--[ Parsers ]--
---------------
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
<> command "set" setP -- [set] KEY VALUE at help lhs
<> command "show" showP
)
<|> argsP -- add show for a single option
<|> pure ShowConfig
where
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
setP = info argsP (progDesc "Set config KEY to VALUE")
argsP = SetConfig <$> argument str (metavar "KEY") <*> argument str (metavar "VALUE")
--------------
--[ Footer ]--
--------------
configFooter :: String
configFooter = [s|Examples:
# show current config
ghcup config
# initialize config
ghcup config init
# set <key> <value> configuration pair
ghcup config <key> <value>|]
-----------------
--[ Utilities ]--
-----------------
formatConfig :: UserSettings -> String
formatConfig = UTF8.toString . Y.encode1Strict
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
updateSettings config' settings = do
settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config'
pure $ mergeConf settings' settings
where
mergeConf :: UserSettings -> Settings -> Settings
mergeConf UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache
noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
------------------
--[ Entrypoint ]--
------------------
config :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> ConfigCommand
-> Settings
-> KeyBindings
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
config configCommand settings keybindings runLogger = case configCommand of
InitConfig -> do
path <- getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
pure ExitSuccess
ShowConfig -> do
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
pure ExitSuccess
(SetConfig k v) -> do
case v of
"" -> do
runLogger $ logError "Empty values are not allowed"
pure $ ExitFailure 55
_ -> do
r <- runE @'[JSONError] $ do
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
lift $ runLogger $ logDebug $ T.pack $ show settings'
pure ()
case r of
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65

View File

@ -0,0 +1,119 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.DInfo where
import GHCup
import GHCup.Errors
import GHCup.Version
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.Dirs
import GHCup.Utils.Logger
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Utils.File
import Language.Haskell.TH
-----------------
--[ Utilities ]--
-----------------
describe_result :: String
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False)
dirs
defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure _ -> pure numericVer
)
)
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
"==========" <> "\n" <>
"GHCup base dir: " <> diBaseDir <> "\n" <>
"GHCup bin dir: " <> diBinDir <> "\n" <>
"GHCup GHC directory: " <> diGHCDir <> "\n" <>
"GHCup cache directory: " <> diCacheDir <> "\n" <>
"Architecture: " <> prettyShow diArch <> "\n" <>
"Platform: " <> prettyShow diPlatform <> "\n" <>
"Version: " <> describe_result
---------------------------
--[ Effect interpreters ]--
---------------------------
type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
-> Excepts DInfoEffects (ReaderT env m) a
-> m (VEither DInfoEffects a)
runDebugInfo runAppState =
runAppState
. runE
@DInfoEffects
------------------
--[ Entrypoint ]--
------------------
dinfo :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, Alternative m
)
=> (ReaderT AppState m (VEither DInfoEffects DebugInfo)
-> m (VEither DInfoEffects DebugInfo))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
dinfo runAppState runLogger = do
runDebugInfo runAppState (liftE getDebugInfo)
>>= \case
VRight di -> do
liftIO $ putStrLn $ prettyDebugInfo di
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8

View File

@ -0,0 +1,143 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.GC where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
---------------
--[ Options ]--
---------------
data GCOptions = GCOptions
{ gcOldGHC :: Bool
, gcProfilingLibs :: Bool
, gcShareDir :: Bool
, gcHLSNoGHC :: Bool
, gcCache :: Bool
, gcTmp :: Bool
}
---------------
--[ Parsers ]--
---------------
gcP :: Parser GCOptions
gcP =
GCOptions
<$>
switch
(short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
<*>
switch
(short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
<*>
switch
(short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
<*>
switch
(short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
<*>
switch
(short 'c' <> long "cache" <> help "GC the GHCup cache")
<*>
switch
(short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
--------------
--[ Footer ]--
--------------
gcFooter :: String
gcFooter = [s|Discussion:
Performs garbage collection. If no switches are specified, does nothing.|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type GCEffects = '[ NotInstalled ]
runGC :: MonadUnliftIO m
=> (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
-> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither GCEffects a)
runGC runAppState =
runAppState
. runResourceT
. runE
@GCEffects
------------------
--[ Entrypoint ]--
------------------
gc :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> GCOptions
-> (forall a. ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC rmOldGHC
lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir
lift $ when gcHLSNoGHC rmHLSNoGHC
lift $ when gcCache rmCache
lift $ when gcTmp rmTmp
) >>= \case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 27

View File

@ -0,0 +1,464 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module GHCup.OptParse.Install where
import GHCup.OptParse.Common
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
import Codec.Archive
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Either
import Data.Functor
import Data.Maybe
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
import qualified Data.Text as T
----------------
--[ Commands ]--
----------------
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
| InstallStack InstallOptions
---------------
--[ Options ]--
---------------
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
}
---------------
--[ Footers ]--
---------------
installCabalFooter :: String
installCabalFooter = [s|Discussion:
Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by
default. Make sure to set up your PATH appropriately, so the cabal
installation takes precedence.|]
---------------
--[ Parsers ]--
---------------
installParser :: Parser (Either InstallCommand InstallOptions)
installParser =
(Left <$> subparser
( command
"ghc"
( InstallGHC
<$> info
(installOpts (Just GHC) <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
<> command
"cabal"
( InstallCabal
<$> info
(installOpts (Just Cabal) <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
<> command
"hls"
( InstallHLS
<$> info
(installOpts (Just HLS) <**> helper)
( progDesc "Install haskell-language-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
<> command
"stack"
( InstallStack
<$> info
(installOpts (Just Stack) <**> helper)
( progDesc "Install stack"
<> footerDoc (Just $ text installStackFooter)
)
)
)
)
<|> (Right <$> installOpts Nothing)
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
Installs haskell-language-server binaries and wrapper
into "~/.ghcup/bin"
Examples:
# install recommended HLS
ghcup install hls|]
installStackFooter :: String
installStackFooter = [s|Discussion:
Installs stack binaries into "~/.ghcup/bin"
Examples:
# install recommended Stack
ghcup install stack|]
installGHCFooter :: String
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install recommended GHC
ghcup install ghc
# install latest GHC
ghcup install ghc latest
# install GHC 8.10.2
ghcup install ghc 8.10.2
# install GHC head fedora bindist
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b is f -> InstallOptions v p u b is f)
<$> optional
(option
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> ( ( (,)
<$> optional
(option
(eitherReader bindistParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
)
)
<*> (Just <$> toolVersionArgument Nothing tool)
)
<|> pure (Nothing, Nothing)
)
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated dir instead of the default one"
)
)
<*> switch
(short 'f' <> long "force" <> help "Force install")
--------------
--[ Footer ]--
--------------
installToolFooter :: String
installToolFooter = [s|Discussion:
Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag.
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type InstallEffects = '[ AlreadyInstalled
, UnknownArchive
, ArchiveResult
, FileDoesNotExistError
, CopyError
, NotInstalled
, DirNotEmpty
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
]
runInstTool :: AppState
-> Maybe PlatformRequest
-> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallEffects a)
runInstTool appstate' mInstPlatform =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT
. runE
@InstallEffects
-------------------
--[ Entrypoints ]--
-------------------
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install installCommand settings getAppState' runLogger = case installCommand of
(Right iopts) -> do
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
installGHC iopts
(Left (InstallGHC iopts)) -> installGHC iopts
(Left (InstallCabal iopts)) -> installCabal iopts
(Left (InstallHLS iopts)) -> installHLS iopts
(Left (InstallStack iopts)) -> installStack iopts
where
installGHC :: InstallOptions -> IO ExitCode
installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin
(_tvVersion v)
isolateDir
forceInstall
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
runInstTool s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
forceInstall
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3
installCabal :: InstallOptions -> IO ExitCode
installCabal InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin
(_tvVersion v)
isolateDir
forceInstall
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
installHLS :: InstallOptions -> IO ExitCode
installHLS InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin
(_tvVersion v)
isolateDir
forceInstall
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
installStack :: InstallOptions -> IO ExitCode
installStack InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin
(_tvVersion v)
isolateDir
forceInstall
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4

View File

@ -0,0 +1,268 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.List where
import GHCup
import GHCup.Types
import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Char
import Data.List ( intercalate, sort )
import Data.Functor
import Data.Maybe
import Data.Versions hiding ( str )
import Data.Void
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import System.Console.Pretty hiding ( color )
import qualified Data.Text as T
import qualified System.Console.Pretty as Pretty
import Control.Exception.Safe (MonadMask)
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
---------------
--[ Options ]--
---------------
data ListOptions = ListOptions
{ loTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
, lRawFormat :: Bool
}
---------------
--[ Parsers ]--
---------------
listOpts :: Parser ListOptions
listOpts =
ListOptions
<$> optional
(option
(eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
"Tool to list versions for. Default is all"
)
)
<*> optional
(option
(eitherReader criteriaParser)
( short 'c'
<> long "show-criteria"
<> metavar "<installed|set|available>"
<> help "Show only installed/set/available tool versions"
)
)
<*> switch
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
)
-----------------
--[ Utilities ]--
-----------------
printListResult :: Bool -> Bool -> [ListResult] -> IO ()
printListResult no_color raw lr = do
let
color | raw || no_color = (\_ x -> x)
| otherwise = Pretty.color
let
printTag Recommended = color Green "recommended"
printTag Latest = color Yellow "latest"
printTag Prerelease = color Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag Old = ""
let
rows =
(\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
. fmap
(\ListResult {..} ->
let marks = if
#if defined(IS_WINDOWS)
| lSet -> (color Green "IS")
| lInstalled -> (color Green "I ")
| otherwise -> (color Red "X ")
#else
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
#endif
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," (filter (/= "") . fmap printTag $ sort lTag)
, intercalate ","
$ (if hlsPowered
then [color Green "hls-powered"]
else mempty
)
++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Yellow "stray"] else mempty)
++ (if lNoBindist
then [color Red "no-bindist"]
else mempty
)
]
)
$ lr
let cols =
foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
lengths = fmap (maximum . fmap strWidth) cols
padded = fmap (\xs -> zipWith padTo xs lengths) rows
forM_ padded $ \row -> putStrLn $ unwords row
where
padTo str' x =
let lstr = strWidth str'
add' = x - lstr
in if add' < 0 then str' else str' ++ replicate add' ' '
-- | Calculate the render width of a string, considering
-- wide characters (counted as double width), ANSI escape codes
-- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width).
strWidth :: String -> Int
strWidth =
maximum
. (0 :)
. map (foldr (\a b -> charWidth a + b) 0)
. lines
. stripAnsi
-- | Strip ANSI escape sequences from a string.
--
-- >>> stripAnsi "\ESC[31m-1\ESC[m"
-- "-1"
stripAnsi :: String -> String
stripAnsi s' =
case
MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
of
Nothing -> error "Bad ansi escape" -- PARTIAL: should not happen
Just xs -> concat xs
where
-- This parses lots of invalid ANSI escape codes, but that should be fine
ansi =
MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
Void
String
Char
digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-- | Get the designated render width of a character: 0 for a combining
-- character, 1 for a regular character, 2 for a wide character.
-- (Wide characters are rendered as exactly double width in apps and
-- fonts that support it.) (From Pandoc.)
charWidth :: Char -> Int
charWidth c = case c of
_ | c < '\x0300' -> 1
| c >= '\x0300' && c <= '\x036F' -> 0
| -- combining
c >= '\x0370' && c <= '\x10FC' -> 1
| c >= '\x1100' && c <= '\x115F' -> 2
| c >= '\x1160' && c <= '\x11A2' -> 1
| c >= '\x11A3' && c <= '\x11A7' -> 2
| c >= '\x11A8' && c <= '\x11F9' -> 1
| c >= '\x11FA' && c <= '\x11FF' -> 2
| c >= '\x1200' && c <= '\x2328' -> 1
| c >= '\x2329' && c <= '\x232A' -> 2
| c >= '\x232B' && c <= '\x2E31' -> 1
| c >= '\x2E80' && c <= '\x303E' -> 2
| c == '\x303F' -> 1
| c >= '\x3041' && c <= '\x3247' -> 2
| c >= '\x3248' && c <= '\x324F' -> 1
| -- ambiguous
c >= '\x3250' && c <= '\x4DBF' -> 2
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
| c >= '\x4E00' && c <= '\xA4C6' -> 2
| c >= '\xA4D0' && c <= '\xA95F' -> 1
| c >= '\xA960' && c <= '\xA97C' -> 2
| c >= '\xA980' && c <= '\xABF9' -> 1
| c >= '\xAC00' && c <= '\xD7FB' -> 2
| c >= '\xD800' && c <= '\xDFFF' -> 1
| c >= '\xE000' && c <= '\xF8FF' -> 1
| -- ambiguous
c >= '\xF900' && c <= '\xFAFF' -> 2
| c >= '\xFB00' && c <= '\xFDFD' -> 1
| c >= '\xFE00' && c <= '\xFE0F' -> 1
| -- ambiguous
c >= '\xFE10' && c <= '\xFE19' -> 2
| c >= '\xFE20' && c <= '\xFE26' -> 1
| c >= '\xFE30' && c <= '\xFE6B' -> 2
| c >= '\xFE70' && c <= '\xFEFF' -> 1
| c >= '\xFF01' && c <= '\xFF60' -> 2
| c >= '\xFF61' && c <= '\x16A38' -> 1
| c >= '\x1B000' && c <= '\x1B001' -> 2
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
| c >= '\x1F200' && c <= '\x1F251' -> 2
| c >= '\x1F300' && c <= '\x1F773' -> 1
| c >= '\x20000' && c <= '\x3FFFD' -> 2
| otherwise -> 1
------------------
--[ Entrypoint ]--
------------------
list :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> ListOptions
-> Bool
-> (ReaderT AppState m ExitCode -> m ExitCode)
-> m ExitCode
list ListOptions{..} no_color runAppState =
runAppState (do
l <- listVersions loTool lCriteria
liftIO $ printListResult no_color lRawFormat l
pure ExitSuccess
)

View File

@ -0,0 +1,99 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Nuke where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import Control.DeepSeq
import Control.Exception
import Control.Concurrent (threadDelay)
---------------------------
--[ Effect interpreters ]--
---------------------------
type NukeEffects = '[ NotInstalled ]
runNuke :: AppState
-> Excepts NukeEffects (ReaderT AppState m) a
-> m (VEither NukeEffects a)
runNuke s' =
flip runReaderT s' . runE @NukeEffects
------------------
--[ Entrypoint ]--
------------------
nuke :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> IO AppState
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
nuke appState runLogger = do
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' (do
lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
forM_ lInstalled (liftE . rmTool)
lift rmGhcupDirs
) >>= \case
VRight leftOverFiles
| null leftOverFiles -> do
runLogger $ logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
| otherwise -> do
runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
liftIO $ forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15

View File

@ -0,0 +1,219 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Prefetch where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Utils.Prelude
import GHCup.Download (getDownloadsF)
----------------
--[ Commands ]--
----------------
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
| PrefetchCabal PrefetchOptions (Maybe ToolVersion)
| PrefetchHLS PrefetchOptions (Maybe ToolVersion)
| PrefetchStack PrefetchOptions (Maybe ToolVersion)
| PrefetchMetadata
---------------
--[ Options ]--
---------------
data PrefetchOptions = PrefetchOptions {
pfCacheDir :: Maybe FilePath
}
data PrefetchGHCOptions = PrefetchGHCOptions {
pfGHCSrc :: Bool
, pfGHCCacheDir :: Maybe FilePath
}
---------------
--[ Parsers ]--
---------------
prefetchP :: Parser PrefetchCommand
prefetchP = subparser
( command
"ghc"
(info
(PrefetchGHC
<$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> optional (toolVersionArgument Nothing (Just GHC)) )
( progDesc "Download GHC assets for installation")
)
<>
command
"cabal"
(info
(PrefetchCabal
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation")
)
<>
command
"hls"
(info
(PrefetchHLS
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation")
)
<>
command
"stack"
(info
(PrefetchStack
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation")
)
<>
command
"metadata"
(PrefetchMetadata <$ info
helper
( progDesc "Download ghcup's metadata, needed for various operations")
)
)
--------------
--[ Footer ]--
--------------
prefetchFooter :: String
prefetchFooter = [s|Discussion:
Prefetches tools or assets into "~/.ghcup/cache" directory. This can
be then combined later with '--offline' flag, ensuring all assets that
are required for offline use have been prefetched.
Examples:
ghcup prefetch metadata
ghcup prefetch ghc 8.10.5
ghcup --offline install ghc 8.10.5|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type PrefetchEffects = '[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, GPGError
, DownloadFailed
, JSONError
, FileDoesNotExistError ]
runPrefetch :: MonadUnliftIO m
=> (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
-> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither PrefetchEffects a)
runPrefetch runAppState =
runAppState
. runResourceT
. runE
@PrefetchEffects
------------------
--[ Entrypoint ]--
------------------
prefetch :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> PrefetchCommand
-> (forall a. ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
prefetch prefetchCommand runAppState runLogger =
runPrefetch runAppState (do
case prefetchCommand of
PrefetchGHC
(PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Cabal
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt HLS
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
PrefetchStack PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
PrefetchMetadata -> do
_ <- liftE getDownloadsF
pure ""
) >>= \case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15

View File

@ -0,0 +1,232 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Rm where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
----------------
--[ Commands ]--
----------------
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
| RmStack Version
---------------
--[ Options ]--
---------------
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
}
---------------
--[ Parsers ]--
---------------
rmParser :: Parser (Either RmCommand RmOptions)
rmParser =
(Left <$> subparser
( command
"ghc"
(RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
<> command
"cabal"
( RmCabal
<$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
(progDesc "Remove Cabal version")
)
<> command
"hls"
( RmHLS
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
<> command
"stack"
( RmStack
<$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
(progDesc "Remove stack version")
)
)
)
<|> (Right <$> rmOpts Nothing)
rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool
--------------
--[ Footer ]--
--------------
rmFooter :: String
rmFooter = [s|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type RmEffects = '[ NotInstalled ]
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
-> Excepts RmEffects (ReaderT env m) a
-> m (VEither RmEffects a)
runRm runAppState =
runAppState
. runE
@RmEffects
------------------
--[ Entrypoint ]--
------------------
rm :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Either RmCommand RmOptions
-> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
-> m (VEither RmEffects (Maybe VersionInfo)))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
rm rmCommand runAppState runLogger = case rmCommand of
(Right rmopts) -> do
runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
rmGHC' rmopts
(Left (RmGHC rmopts)) -> rmGHC' rmopts
(Left (RmCabal rmopts)) -> rmCabal' rmopts
(Left (RmHLS rmopts)) -> rmHLS' rmopts
(Left (RmStack rmopts)) -> rmStack' rmopts
where
rmGHC' RmOptions{..} =
runRm runAppState (do
liftE $
rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 7
rmCabal' tv =
runRm runAppState (do
liftE $
rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls)
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
rmHLS' tv =
runRm runAppState (do
liftE $
rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls)
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
rmStack' tv =
runRm runAppState (do
liftE $
rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls)
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15

View File

@ -0,0 +1,349 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Set where
import GHCup.OptParse.Common
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Either
import Data.Functor
import Data.Maybe
import Data.Versions hiding ( str )
import GHC.Unicode
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Data.Bifunctor (second)
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
----------------
--[ Commands ]--
----------------
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
| SetHLS SetOptions
| SetStack SetOptions
---------------
--[ Options ]--
---------------
data SetOptions = SetOptions
{ sToolVer :: SetToolVersion
}
---------------
--[ Parsers ]--
---------------
setParser :: Parser (Either SetCommand SetOptions)
setParser =
(Left <$> subparser
( command
"ghc"
( SetGHC
<$> info
(setOpts (Just GHC) <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
)
<> command
"cabal"
( SetCabal
<$> info
(setOpts (Just Cabal) <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
)
<> command
"hls"
( SetHLS
<$> info
(setOpts (Just HLS) <**> helper)
( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter)
)
)
<> command
"stack"
( SetStack
<$> info
(setOpts (Just Stack) <**> helper)
( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter)
)
)
)
)
<|> (Right <$> setOpts Nothing)
where
setGHCFooter :: String
setGHCFooter = [s|Discussion:
Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|]
setCabalFooter :: String
setCabalFooter = [s|Discussion:
Sets the the current Cabal version.|]
setStackFooter :: String
setStackFooter = [s|Discussion:
Sets the the current Stack version.|]
setHLSFooter :: String
setHLSFooter = [s|Discussion:
Sets the the current haskell-language-server version.|]
setOpts :: Maybe Tool -> Parser SetOptions
setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$>
optional (setVersionArgument (Just ListInstalled) tool))
setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
setVersionArgument criteria tool =
argument (eitherReader setEither)
(metavar "VERSION|TAG|next"
<> completer (tagCompleter (fromMaybe GHC tool) ["next"])
<> foldMap (completer . versionCompleter criteria) tool)
where
setEither s' =
parseSet s'
<|> second SetToolTag (tagEither s')
<|> second SetToolVersion (tVersionEither s')
parseSet s' = case fmap toLower s' of
"next" -> Right SetNext
other -> Left $ "Unknown tag/version " <> other
--------------
--[ Footer ]--
--------------
setFooter :: String
setFooter = [s|Discussion:
Sets the currently active GHC or cabal version. When no command is given,
defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version).
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type SetGHCEffects = '[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet]
runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
-> Excepts SetGHCEffects (ReaderT env m) a
-> m (VEither SetGHCEffects a)
runSetGHC runAppState =
runAppState
. runE
@SetGHCEffects
type SetCabalEffects = '[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet]
runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
-> Excepts SetCabalEffects (ReaderT env m) a
-> m (VEither SetCabalEffects a)
runSetCabal runAppState =
runAppState
. runE
@SetCabalEffects
type SetHLSEffects = '[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet]
runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
-> Excepts SetHLSEffects (ReaderT env m) a
-> m (VEither SetHLSEffects a)
runSetHLS runAppState =
runAppState
. runE
@SetHLSEffects
type SetStackEffects = '[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet]
runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
-> Excepts SetStackEffects (ReaderT env m) a
-> m (VEither SetStackEffects a)
runSetStack runAppState =
runAppState
. runE
@SetStackEffects
-------------------
--[ Entrypoints ]--
-------------------
set :: forall m env.
( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, HasDirs env
, HasLog env
)
=> Either SetCommand SetOptions
-> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
-> m (VEither eff GHCTargetVersion))
-> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
-> m (VEither eff GHCTargetVersion))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
set setCommand runAppState runLeanAppState runLogger = case setCommand of
(Right sopts) -> do
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
setGHC' sopts
(Left (SetGHC sopts)) -> setGHC' sopts
(Left (SetCabal sopts)) -> setCabal' sopts
(Left (SetHLS sopts)) -> setHLS' sopts
(Left (SetStack sopts)) -> setStack' sopts
where
setGHC' :: SetOptions
-> m ExitCode
setGHC' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v)
_ -> runSetGHC runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ logInfo $
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 5
setCabal' :: SetOptions
-> m ExitCode
setCabal' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v)
_ -> runSetCabal runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ logInfo $
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
setHLS' :: SetOptions
-> m ExitCode
setHLS' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v)
_ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ logInfo $
"HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
setStack' :: SetOptions
-> m ExitCode
setStack' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v)
_ -> runSetStack runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ logInfo $
"Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14

View File

@ -0,0 +1,82 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.ToolRequirements where
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
import GHCup.Platform
import GHCup.Utils.Prelude
import GHCup.Requirements
import System.IO
---------------------------
--[ Effect interpreters ]--
---------------------------
type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoToolRequirements ]
runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a))
-> Excepts ToolRequirementsEffects (ReaderT env m) a
-> m (VEither ToolRequirementsEffects a)
runToolRequirements runAppState =
runAppState
. runE
@ToolRequirementsEffects
------------------
--[ Entrypoint ]--
------------------
toolRequirements :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, Alternative m
)
=> (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
toolRequirements runAppState runLogger = runToolRequirements runAppState (do
GHCupInfo { .. } <- lift getGHCupInfo
platform' <- liftE getPlatform
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 12

View File

@ -0,0 +1,205 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.UnSet where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
----------------
--[ Commands ]--
----------------
data UnsetCommand = UnsetGHC UnsetOptions
| UnsetCabal UnsetOptions
| UnsetHLS UnsetOptions
| UnsetStack UnsetOptions
---------------
--[ Options ]--
---------------
data UnsetOptions = UnsetOptions
{ sToolVer :: Maybe T.Text -- target platform triple
}
---------------
--[ Parsers ]--
---------------
unsetParser :: Parser UnsetCommand
unsetParser =
subparser
( command
"ghc"
( UnsetGHC
<$> info
(unsetOpts <**> helper)
( progDesc "Unset GHC version"
<> footerDoc (Just $ text unsetGHCFooter)
)
)
<> command
"cabal"
( UnsetCabal
<$> info
(unsetOpts <**> helper)
( progDesc "Unset Cabal version"
<> footerDoc (Just $ text unsetCabalFooter)
)
)
<> command
"hls"
( UnsetHLS
<$> info
(unsetOpts <**> helper)
( progDesc "Unset haskell-language-server version"
<> footerDoc (Just $ text unsetHLSFooter)
)
)
<> command
"stack"
( UnsetStack
<$> info
(unsetOpts <**> helper)
( progDesc "Unset stack version"
<> footerDoc (Just $ text unsetStackFooter)
)
)
)
where
unsetGHCFooter :: String
unsetGHCFooter = [s|Discussion:
Unsets the the current GHC version. That means there won't
be a ~/.ghcup/bin/ghc anymore.|]
unsetCabalFooter :: String
unsetCabalFooter = [s|Discussion:
Unsets the the current Cabal version.|]
unsetStackFooter :: String
unsetStackFooter = [s|Discussion:
Unsets the the current Stack version.|]
unsetHLSFooter :: String
unsetHLSFooter = [s|Discussion:
Unsets the the current haskell-language-server version.|]
unsetOpts :: Parser UnsetOptions
unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE"))
--------------
--[ Footer ]--
--------------
unsetFooter :: String
unsetFooter = [s|Discussion:
Unsets the currently active GHC or cabal version.|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type UnsetEffects = '[ NotInstalled ]
runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
-> Excepts UnsetEffects (ReaderT env m) a
-> m (VEither UnsetEffects a)
runUnsetGHC runLeanAppState =
runLeanAppState
. runE
@UnsetEffects
------------------
--[ Entrypoint ]--
------------------
unset :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, HasDirs env
, HasLog env
)
=> UnsetCommand
-> (ReaderT env m (VEither UnsetEffects ())
-> m (VEither UnsetEffects ()))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
unset unsetCommand runLeanAppState runLogger = case unsetCommand of
(UnsetGHC (UnsetOptions triple)) -> runUnsetGHC runLeanAppState (unsetGHC triple)
>>= \case
VRight _ -> do
runLogger $ logInfo "GHC successfully unset"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
(UnsetCabal (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetCabal)
runLogger $ logInfo "Cabal successfully unset"
pure ExitSuccess
(UnsetHLS (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetHLS)
runLogger $ logInfo "HLS successfully unset"
pure ExitSuccess
(UnsetStack (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetStack)
runLogger $ logInfo "Stack successfully unset"
pure ExitSuccess

View File

@ -0,0 +1,150 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Upgrade where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import System.Environment
import GHCup.Utils
import System.FilePath
import GHCup.Types.Optics
import Data.Versions hiding (str)
---------------
--[ Options ]--
---------------
data UpgradeOpts = UpgradeInplace
| UpgradeAt FilePath
| UpgradeGHCupDir
deriving Show
---------------
--[ Parsers ]--
---------------
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
(short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
<$> option
str
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
<|> pure UpgradeGHCupDir
---------------------------
--[ Effect interpreters ]--
---------------------------
type UpgradeEffects = '[ DigestError
, GPGError
, NoDownload
, NoUpdate
, FileDoesNotExistError
, CopyError
, DownloadFailed
]
runUpgrade :: MonadUnliftIO m
=> (ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
-> Excepts UpgradeEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither UpgradeEffects a)
runUpgrade runAppState =
runAppState
. runResourceT
. runE
@UpgradeEffects
------------------
--[ Entrypoint ]--
------------------
upgrade :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> UpgradeOpts
-> Bool
-> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
upgrade uOpts force' runAppState runLogger = do
VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)
target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
runUpgrade runAppState (do
v' <- liftE $ upgradeGHCup target force'
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (v', dls)
) >>= \case
VRight (v', dls) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ logInfo $
"Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 11

View File

@ -0,0 +1,319 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Whereis where
import GHCup
import GHCup.Errors
import GHCup.OptParse.Common
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import System.FilePath (takeDirectory)
import GHCup.Types.Optics
----------------
--[ Commands ]--
----------------
data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
| WhereisBaseDir
| WhereisBinDir
| WhereisCacheDir
| WhereisLogsDir
| WhereisConfDir
---------------
--[ Options ]--
---------------
data WhereisOptions = WhereisOptions {
directory :: Bool
}
---------------
--[ Parsers ]--
---------------
whereisP :: Parser WhereisCommand
whereisP = subparser
(commandGroup "Tools locations:" <>
command
"ghc"
(WhereisTool GHC <$> info
( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
( progDesc "Get GHC location"
<> footerDoc (Just $ text whereisGHCFooter ))
)
<>
command
"cabal"
(WhereisTool Cabal <$> info
( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )
( progDesc "Get cabal location"
<> footerDoc (Just $ text whereisCabalFooter ))
)
<>
command
"hls"
(WhereisTool HLS <$> info
( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )
( progDesc "Get HLS location"
<> footerDoc (Just $ text whereisHLSFooter ))
)
<>
command
"stack"
(WhereisTool Stack <$> info
( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )
( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter ))
)
<>
command
"ghcup"
(WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
) <|> subparser ( commandGroup "Directory locations:"
<>
command
"basedir"
(info (pure WhereisBaseDir <**> helper)
( progDesc "Get ghcup base directory location" )
)
<>
command
"bindir"
(info (pure WhereisBinDir <**> helper)
( progDesc "Get ghcup binary directory location" )
)
<>
command
"cachedir"
(info (pure WhereisCacheDir <**> helper)
( progDesc "Get ghcup cache directory location" )
)
<>
command
"logsdir"
(info (pure WhereisLogsDir <**> helper)
( progDesc "Get ghcup logs directory location" )
)
<>
command
"confdir"
(info (pure WhereisConfDir <**> helper)
( progDesc "Get ghcup config directory location" )
)
)
where
whereisGHCFooter = [s|Discussion:
Finds the location of a GHC executable, which usually resides in
a self-contained "~/.ghcup/ghc/<ghcver>" directory.
Examples:
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
ghcup whereis ghc 8.10.5
# outputs ~/.ghcup/ghc/8.10.5/bin/
ghcup whereis --directory ghc 8.10.5 |]
whereisCabalFooter = [s|Discussion:
Finds the location of a Cabal executable, which usually resides in
"~/.ghcup/bin/".
Examples:
# outputs ~/.ghcup/bin/cabal-3.4.0.0
ghcup whereis cabal 3.4.0.0
# outputs ~/.ghcup/bin
ghcup whereis --directory cabal 3.4.0.0|]
whereisHLSFooter = [s|Discussion:
Finds the location of a HLS executable, which usually resides in
"~/.ghcup/bin/".
Examples:
# outputs ~/.ghcup/bin/haskell-language-server-wrapper-1.2.0
ghcup whereis hls 1.2.0
# outputs ~/.ghcup/bin/
ghcup whereis --directory hls 1.2.0|]
whereisStackFooter = [s|Discussion:
Finds the location of a stack executable, which usually resides in
"~/.ghcup/bin/".
Examples:
# outputs ~/.ghcup/bin/stack-2.7.1
ghcup whereis stack 2.7.1
# outputs ~/.ghcup/bin/
ghcup whereis --directory stack 2.7.1|]
--------------
--[ Footer ]--
--------------
whereisFooter :: String
whereisFooter = [s|Discussion:
Finds the location of a tool. For GHC, this is the ghc binary, that
usually resides in a self-contained "~/.ghcup/ghc/<ghcver>" directory.
For cabal/stack/hls this the binary usually at "~/.ghcup/bin/<tool>-<ver>".
Examples:
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
ghcup whereis ghc 8.10.5
# outputs ~/.ghcup/ghc/8.10.5/bin/
ghcup whereis --directory ghc 8.10.5
# outputs ~/.ghcup/bin/cabal-3.4.0.0
ghcup whereis cabal 3.4.0.0
# outputs ~/.ghcup/bin/
ghcup whereis --directory cabal 3.4.0.0|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type WhereisEffects = '[ NotInstalled
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
runLeanWhereIs :: (MonadUnliftIO m, MonadIO m)
=> LeanAppState
-> Excepts WhereisEffects (ReaderT LeanAppState m) a
-> m (VEither WhereisEffects a)
runLeanWhereIs leanAppstate =
-- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate.
flip runReaderT leanAppstate
. runE
@WhereisEffects
runWhereIs :: (MonadUnliftIO m, MonadIO m)
=> (ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
-> Excepts WhereisEffects (ReaderT AppState m) a
-> m (VEither WhereisEffects a)
runWhereIs runAppState =
runAppState
. runE
@WhereisEffects
------------------
--[ Entrypoint ]--
------------------
whereis :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> WhereisCommand
-> WhereisOptions
-> (forall a. ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
-> LeanAppState
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
Dirs{ .. } <- runReaderT getDirs leanAppstate
case (whereisCommand, whereisOptions) of
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
runWhereIs runAppState (do
(v, _) <- liftE $ fromVersion whereVer tool
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
(WhereisBaseDir, _) -> do
liftIO $ putStr baseDir
pure ExitSuccess
(WhereisBinDir, _) -> do
liftIO $ putStr binDir
pure ExitSuccess
(WhereisCacheDir, _) -> do
liftIO $ putStr cacheDir
pure ExitSuccess
(WhereisLogsDir, _) -> do
liftIO $ putStr logsDir
pure ExitSuccess
(WhereisConfDir, _) -> do
liftIO $ putStr confDir
pure ExitSuccess

File diff suppressed because it is too large Load Diff

View File

@ -172,6 +172,23 @@ library
executable ghcup executable ghcup
main-is: Main.hs main-is: Main.hs
other-modules: GHCup.OptParse.Install
GHCup.OptParse.Common
GHCup.OptParse.Set
GHCup.OptParse.UnSet
GHCup.OptParse.Rm
GHCup.OptParse.Compile
GHCup.OptParse.Config
GHCup.OptParse.Whereis
GHCup.OptParse.List
GHCup.OptParse.DInfo
GHCup.OptParse.Upgrade
GHCup.OptParse.ToolRequirements
GHCup.OptParse.ChangeLog
GHCup.OptParse.Nuke
GHCup.OptParse.Prefetch
GHCup.OptParse.GC
GHCup.OptParse
hs-source-dirs: app/ghcup hs-source-dirs: app/ghcup
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions: