Merge remote-tracking branch 'origin/merge-requests/70'
This commit is contained in:
commit
45ab69960f
|
|
@ -192,10 +192,10 @@ data ChangeLogOptions = ChangeLogOptions
|
|||
-- by default. For example:
|
||||
--
|
||||
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
|
||||
--
|
||||
-- This example makes --recursive enabled by default, so
|
||||
--
|
||||
-- This example makes --recursive enabled by default, so
|
||||
-- the help is shown only for --no-recursive.
|
||||
invertableSwitch
|
||||
invertableSwitch
|
||||
:: String -- ^ long option
|
||||
-> Char -- ^ short option for the non-default option
|
||||
-> Bool -- ^ is switch enabled by default?
|
||||
|
|
@ -363,7 +363,7 @@ com =
|
|||
( command
|
||||
"install-cabal"
|
||||
((info
|
||||
((InstallCabalLegacy <$> installOpts) <**> helper)
|
||||
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
|
||||
( progDesc "Install or update cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
|
|
@ -413,7 +413,7 @@ installParser =
|
|||
"ghc"
|
||||
( InstallGHC
|
||||
<$> (info
|
||||
(installOpts <**> helper)
|
||||
(installOpts (Just GHC) <**> helper)
|
||||
( progDesc "Install GHC"
|
||||
<> footerDoc (Just $ text installGHCFooter)
|
||||
)
|
||||
|
|
@ -423,7 +423,7 @@ installParser =
|
|||
"cabal"
|
||||
( InstallCabal
|
||||
<$> (info
|
||||
(installOpts <**> helper)
|
||||
(installOpts (Just Cabal) <**> helper)
|
||||
( progDesc "Install Cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
|
|
@ -433,7 +433,7 @@ installParser =
|
|||
"hls"
|
||||
( InstallHLS
|
||||
<$> (info
|
||||
(installOpts <**> helper)
|
||||
(installOpts (Just HLS) <**> helper)
|
||||
( progDesc "Install haskell-languge-server"
|
||||
<> footerDoc (Just $ text installHLSFooter)
|
||||
)
|
||||
|
|
@ -441,7 +441,7 @@ installParser =
|
|||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> installOpts)
|
||||
<|> (Right <$> installOpts Nothing)
|
||||
where
|
||||
installHLSFooter :: String
|
||||
installHLSFooter = [s|Discussion:
|
||||
|
|
@ -472,8 +472,8 @@ Examples:
|
|||
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 :: Parser InstallOptions
|
||||
installOpts =
|
||||
installOpts :: Maybe Tool -> Parser InstallOptions
|
||||
installOpts tool =
|
||||
(\p (u, v) b -> InstallOptions v p u b)
|
||||
<$> (optional
|
||||
(option
|
||||
|
|
@ -495,9 +495,9 @@ installOpts =
|
|||
)
|
||||
)
|
||||
)
|
||||
<*> (Just <$> toolVersionArgument)
|
||||
<*> (Just <$> toolVersionArgument True Nothing tool)
|
||||
)
|
||||
<|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
|
||||
<|> (pure (Nothing, Nothing))
|
||||
)
|
||||
<*> flag
|
||||
False
|
||||
|
|
@ -514,7 +514,7 @@ setParser =
|
|||
"ghc"
|
||||
( SetGHC
|
||||
<$> (info
|
||||
(setOpts <**> helper)
|
||||
(setOpts (Just GHC) <**> helper)
|
||||
( progDesc "Set GHC version"
|
||||
<> footerDoc (Just $ text setGHCFooter)
|
||||
)
|
||||
|
|
@ -524,7 +524,7 @@ setParser =
|
|||
"cabal"
|
||||
( SetCabal
|
||||
<$> (info
|
||||
(setOpts <**> helper)
|
||||
(setOpts (Just Cabal) <**> helper)
|
||||
( progDesc "Set Cabal version"
|
||||
<> footerDoc (Just $ text setCabalFooter)
|
||||
)
|
||||
|
|
@ -534,7 +534,7 @@ setParser =
|
|||
"hls"
|
||||
( SetHLS
|
||||
<$> (info
|
||||
(setOpts <**> helper)
|
||||
(setOpts (Just HLS) <**> helper)
|
||||
( progDesc "Set haskell-language-server version"
|
||||
<> footerDoc (Just $ text setHLSFooter)
|
||||
)
|
||||
|
|
@ -542,7 +542,7 @@ setParser =
|
|||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> setOpts)
|
||||
<|> (Right <$> setOpts Nothing)
|
||||
where
|
||||
setGHCFooter :: String
|
||||
setGHCFooter = [s|Discussion:
|
||||
|
|
@ -559,8 +559,8 @@ setParser =
|
|||
Sets the the current haskell-language-server version.|]
|
||||
|
||||
|
||||
setOpts :: Parser SetOptions
|
||||
setOpts = SetOptions <$> optional toolVersionArgument
|
||||
setOpts :: Maybe Tool -> Parser SetOptions
|
||||
setOpts tool = SetOptions <$> optional (toolVersionArgument False (Just ListInstalled) tool)
|
||||
|
||||
listOpts :: Parser ListOptions
|
||||
listOpts =
|
||||
|
|
@ -592,29 +592,29 @@ rmParser =
|
|||
(Left <$> subparser
|
||||
( command
|
||||
"ghc"
|
||||
(RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version")))
|
||||
(RmGHC <$> (info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version")))
|
||||
<> command
|
||||
"cabal"
|
||||
( RmCabal
|
||||
<$> (info (versionParser' <**> helper)
|
||||
<$> (info (versionParser' False (Just ListInstalled) (Just Cabal) <**> helper)
|
||||
(progDesc "Remove Cabal version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( RmHLS
|
||||
<$> (info (versionParser' <**> helper)
|
||||
<$> (info (versionParser' False (Just ListInstalled) (Just HLS) <**> helper)
|
||||
(progDesc "Remove haskell-language-server version")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> rmOpts)
|
||||
<|> (Right <$> rmOpts Nothing)
|
||||
|
||||
|
||||
|
||||
rmOpts :: Parser RmOptions
|
||||
rmOpts = RmOptions <$> versionArgument
|
||||
rmOpts :: Maybe Tool -> Parser RmOptions
|
||||
rmOpts tool = RmOptions <$> versionArgument False (Just ListInstalled) tool
|
||||
|
||||
|
||||
changelogP :: Parser ChangeLogOptions
|
||||
|
|
@ -636,7 +636,7 @@ changelogP =
|
|||
)
|
||||
)
|
||||
)
|
||||
<*> optional toolVersionArgument
|
||||
<*> optional (toolVersionArgument True Nothing Nothing)
|
||||
|
||||
compileP :: Parser CompileCommand
|
||||
compileP = subparser
|
||||
|
|
@ -765,13 +765,72 @@ toolVersionParser = verP' <|> toolP
|
|||
)
|
||||
|
||||
-- | same as toolVersionParser, except as an argument.
|
||||
toolVersionArgument :: Parser ToolVersion
|
||||
toolVersionArgument =
|
||||
argument (eitherReader toolVersionEither) (metavar "VERSION|TAG")
|
||||
toolVersionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
|
||||
toolVersionArgument networkSensitive criteria tool =
|
||||
argument (eitherReader toolVersionEither) (metavar "VERSION|TAG" <> completer tagCompleter <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
|
||||
|
||||
|
||||
versionArgument :: Parser GHCTargetVersion
|
||||
versionArgument = argument (eitherReader tVersionEither) (metavar "VERSION")
|
||||
versionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
|
||||
versionArgument networkSensitive criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
|
||||
|
||||
|
||||
tagCompleter :: Completer
|
||||
tagCompleter =
|
||||
listCompleter [
|
||||
"recommended", "latest"
|
||||
]
|
||||
|
||||
|
||||
versionCompleter :: Bool -> Maybe ListCriteria -> Tool -> Completer
|
||||
versionCompleter networkSensitive criteria tool =
|
||||
listIOCompleter $ do
|
||||
let
|
||||
loggerConfig =
|
||||
LoggerConfig
|
||||
{ lcPrintDebug = False
|
||||
, colorOutter = mempty
|
||||
, rawOutter = mempty
|
||||
}
|
||||
|
||||
runLogger =
|
||||
myLoggerT loggerConfig
|
||||
|
||||
downloadWithUserSource = do
|
||||
userConf <- runE @'[ JSONError ] ghcupConfigFile
|
||||
getDownloadsF $
|
||||
veitherCont (const GHCupURL) (fromMaybe GHCupURL . uUrlSource) userConf
|
||||
|
||||
mpFreq <-
|
||||
runLogger . runE $
|
||||
platformRequest
|
||||
|
||||
forFold mpFreq $ \pfreq -> do
|
||||
dirs <- getDirs
|
||||
let
|
||||
simpleSettings =
|
||||
Settings False False Never Curl False GHCupURL
|
||||
simpleAppState =
|
||||
AppState simpleSettings dirs defaultKeyBindings
|
||||
runEnv =
|
||||
runLogger . flip runReaderT simpleAppState
|
||||
|
||||
mGhcUpInfo <-
|
||||
runEnv . runE $
|
||||
if networkSensitive then do
|
||||
downloadWithUserSource
|
||||
else
|
||||
catchE
|
||||
(\(FileDoesNotExistError _) -> downloadWithUserSource)
|
||||
readFromCache
|
||||
|
||||
forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do
|
||||
installedVersions <-
|
||||
runEnv $
|
||||
listVersions dls (Just tool) criteria pfreq
|
||||
|
||||
return $
|
||||
T.unpack . prettyVer . lVer <$> installedVersions
|
||||
|
||||
|
||||
versionParser :: Parser GHCTargetVersion
|
||||
versionParser = option
|
||||
|
|
@ -779,10 +838,10 @@ versionParser = option
|
|||
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
|
||||
)
|
||||
|
||||
versionParser' :: Parser Version
|
||||
versionParser' = argument
|
||||
(eitherReader (bimap show id . version . T.pack))
|
||||
(metavar "VERSION")
|
||||
versionParser' :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser Version
|
||||
versionParser' networkSensitive criteria tool = argument
|
||||
(eitherReader (first show . version . T.pack))
|
||||
(metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
|
||||
|
||||
|
||||
tagEither :: String -> Either String Tag
|
||||
|
|
@ -792,7 +851,7 @@ tagEither s' = case fmap toLower s' of
|
|||
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
|
||||
Right x -> Right (Base x)
|
||||
Left _ -> Left [i|Invalid PVP version for base #{ver'}|]
|
||||
other -> Left ([i|Unknown tag #{other}|])
|
||||
other -> Left [i|Unknown tag #{other}|]
|
||||
|
||||
|
||||
tVersionEither :: String -> Either String GHCTargetVersion
|
||||
|
|
|
|||
|
|
@ -137,30 +137,8 @@ getDownloadsF urlSource = do
|
|||
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
|
||||
ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt)
|
||||
pure (mergeGhcupInfo base ext)
|
||||
where
|
||||
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
|
||||
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
|
||||
readFromCache = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
||||
$ liftIO
|
||||
$ readFile yaml_file
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
|
||||
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
|
||||
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
|
||||
getBase =
|
||||
handleIO (\_ -> readFromCache)
|
||||
$ catchE @_ @'[JSONError, FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache)
|
||||
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
|
||||
where
|
||||
|
||||
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
|
||||
-> GHCupInfo -- ^ extension overwriting the base
|
||||
|
|
@ -172,6 +150,32 @@ getDownloadsF urlSource = do
|
|||
) base
|
||||
in GHCupInfo tr new
|
||||
|
||||
|
||||
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
|
||||
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
|
||||
readFromCache = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
||||
$ liftIO
|
||||
$ readFile yaml_file
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
|
||||
|
||||
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
|
||||
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
|
||||
getBase =
|
||||
handleIO (\_ -> readFromCache)
|
||||
$ catchE @_ @'[JSONError, FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache)
|
||||
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
|
||||
where
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
|
|
@ -209,8 +213,8 @@ getDownloadsF urlSource = do
|
|||
then do
|
||||
accessTime <-
|
||||
PF.accessTimeHiRes
|
||||
<$> (liftIO $ PF.getFileStatus (toFilePath json_file))
|
||||
currentTime <- liftIO $ getPOSIXTime
|
||||
<$> liftIO (PF.getFileStatus (toFilePath json_file))
|
||||
currentTime <- liftIO getPOSIXTime
|
||||
|
||||
-- access time won't work on most linuxes, but we can try regardless
|
||||
if (currentTime - accessTime) > 300
|
||||
|
|
|
|||
|
|
@ -808,3 +808,12 @@ getVersionInfo v' tool dls =
|
|||
% _head
|
||||
)
|
||||
dls
|
||||
|
||||
|
||||
-- Gathering monoidal values
|
||||
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
|
||||
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
|
||||
|
||||
-- | Gathering monoidal values
|
||||
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
|
||||
forFold = flip traverseFold
|
||||
|
|
|
|||
|
|
@ -185,9 +185,9 @@ getDirs = do
|
|||
ghcupConfigFile :: (MonadIO m)
|
||||
=> Excepts '[JSONError] m UserSettings
|
||||
ghcupConfigFile = do
|
||||
confDir <- liftIO $ ghcupConfigDir
|
||||
confDir <- liftIO ghcupConfigDir
|
||||
let file = confDir </> [rel|config.yaml|]
|
||||
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file
|
||||
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
|
||||
case bs of
|
||||
Nothing -> pure defaultUserSettings
|
||||
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'
|
||||
|
|
|
|||
Loading…
Reference in New Issue