Merge branch 'stack-support'

This commit is contained in:
Julian Ospald 2021-05-15 22:13:39 +02:00
commit 8ef1c8b5d4
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
15 changed files with 19237 additions and 18477 deletions

View File

@ -10,8 +10,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./gh
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
exit 0

View File

@ -12,8 +12,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
exit 0

View File

@ -28,8 +28,8 @@ else
fi
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
# utils
apk add --no-cache \

View File

@ -13,7 +13,7 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}

View File

@ -96,14 +96,19 @@ eghcup set ${GHC_VERSION}
eghcup rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
# install hls
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
eghcup install stack
stack --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
eghcup install stack
stack --version
fi
fi

View File

@ -5,6 +5,11 @@
* Add date to GHC bindist names created by ghcup
* Warn when /tmp doesn't have 5GB or more of disk space
* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
* Add stack support
## 0.1.14.2 -- 2021-05-12
* Remove dead dependency on ascii-string
## 0.1.14.1 -- 2021-04-11

View File

@ -66,7 +66,8 @@ data BrickData = BrickData
deriving Show
data BrickSettings = BrickSettings
{ showAll :: Bool
{ showAllVersions :: Bool
, showAllTools :: Bool
}
deriving Show
@ -97,17 +98,22 @@ keyHandlers KeyBindings {..} =
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAll
, ( bShowAllVersions
, \BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions"
, hideShowHandler
if showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler (not . showAllVersions) showAllTools
)
, ( bShowAllTools
, \BrickSettings {..} ->
if showAllTools then "Don't show all tools" else "Show all tools"
, hideShowHandler showAllVersions (not . showAllTools)
)
, (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
, (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
]
where
hideShowHandler BrickState{..} =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
hideShowHandler f p BrickState{..} =
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (BrickState appData newAppSettings newInternalState appKeys)
@ -142,7 +148,12 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
<+> minHSize 15 (str "Version")
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes")
renderList' = withDefAttr listAttr . drawListElements renderItem True
renderList' = withDefAttr listAttr . drawListElements renderItem True . filterStack
filterStack appState'
| showAllTools as = appState'
| let v = clr appState'
nv = V.filter (\ListResult{..} -> lTool /= Stack) v
, otherwise = BrickInternalState { clr = nv, ix = ix appState' }
renderItem _ b listResult@ListResult{..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
@ -194,6 +205,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printTool GHC = str "GHC"
printTool GHCup = str "GHCup"
printTool HLS = str "HLS"
printTool Stack = str "Stack"
printNotes ListResult {..} =
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
@ -351,7 +363,7 @@ constructList :: BrickData
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings =
replaceLR (filterVisible (showAll appSettings)) (lr appD)
replaceLR (filterVisible (showAllVersions appSettings)) (lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
@ -385,9 +397,9 @@ replaceLR filterF lr s =
filterVisible :: Bool -> ListResult -> Bool
filterVisible showAll e | lInstalled e = True
| showAll = True
| otherwise = not (elem Old (lTag e))
filterVisible showAllVersions e | lInstalled e = True
| showAllVersions = True
| otherwise = not (elem Old (lTag e))
install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
@ -432,6 +444,9 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin dls lVer pfreq $> vi
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin dls lVer pfreq $> vi
)
>>= \case
VRight vi -> do
@ -460,6 +475,7 @@ set' _ (_, ListResult {..}) = do
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)
>>= \case
@ -481,6 +497,7 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi
HLS -> liftE $ rmHLSVer lVer $> vi
Stack -> liftE $ rmStackVer lVer $> vi
GHCup -> pure Nothing
)
>>= \case
@ -564,7 +581,7 @@ brickMain s l av pfreq' = do
defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAll = False }
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
getDownloads' :: IO (Either String GHCupDownloads)

View File

@ -126,6 +126,7 @@ toSetToolVer Nothing = SetRecommended
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
| InstallStack InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
@ -137,6 +138,7 @@ data InstallOptions = InstallOptions
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
| SetHLS SetOptions
| SetStack SetOptions
-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
@ -157,6 +159,7 @@ data ListOptions = ListOptions
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
| RmStack Version
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
@ -432,6 +435,15 @@ installParser =
<> footerDoc (Just $ text installHLSFooter)
)
)
<> command
"stack"
( InstallStack
<$> info
(installOpts (Just Stack) <**> helper)
( progDesc "Install stack"
<> footerDoc (Just $ text installStackFooter)
)
)
)
)
<|> (Right <$> installOpts Nothing)
@ -442,9 +454,17 @@ installParser =
into "~/.ghcup/bin"
Examples:
# install recommended GHC
# 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
@ -528,6 +548,15 @@ setParser =
<> footerDoc (Just $ text setHLSFooter)
)
)
<> command
"stack"
( SetStack
<$> info
(setOpts (Just Stack) <**> helper)
( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter)
)
)
)
)
<|> (Right <$> setOpts Nothing)
@ -542,6 +571,10 @@ setParser =
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.|]
@ -594,6 +627,12 @@ rmParser =
<$> 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)
@ -615,6 +654,7 @@ changelogP =
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
"stack" -> Right Stack
e -> Left e
)
)
@ -986,7 +1026,8 @@ toSettings options = do
, bUninstall = fromMaybe bUninstall kUninstall
, bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog
, bShowAll = fromMaybe bShowAll kShowAll
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
}
@ -1325,6 +1366,36 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let installStack InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer Stack
liftE $ installStackBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
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)
[i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
runSetGHC (do
@ -1373,6 +1444,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setStack' SetOptions{..} =
runSetCabal (do
v <- liftE $ fst <$> fromVersion' dls sToolVer Stack
liftE $ setStack (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo)
[i|Stack #{prettyVer _tvVersion} successfully set as default version|]
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
runRm (do
liftE $
@ -1418,6 +1505,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmStack' tv =
runRm (do
liftE $
rmStackVer tv
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
res <- case optCommand of
#if defined(BRICK)
@ -1429,6 +1530,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
installCabal iopts
@ -1439,6 +1541,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
Set (Left (SetHLS sopts)) -> setHLS' sopts
Set (Left (SetStack sopts)) -> setStack' sopts
List ListOptions {..} ->
runListGHC (do
@ -1453,6 +1556,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
Rm (Left (RmStack rmopts)) -> rmStack' rmopts
DInfo ->
do runDebugInfo $ liftE getDebugInfo
@ -1654,6 +1758,16 @@ fromVersion' av SetNext tool = do
. 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 av
pure (next, vi)
@ -1852,6 +1966,13 @@ checkForUpdates dls pfreq = do
$ $(logWarn)
[i|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)
[i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info

View File

@ -29,6 +29,8 @@ key-bindings:
KChar: 'c'
show-all:
KChar: 'a'
show-all-tools:
KChar: 't'
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code.

View File

@ -1835,3 +1835,45 @@ ghcupDownloads:
dlHash: 4e89b192e2f49637d772e974f2c17b16da067ecd5912575eaa542551de97681b
Linux_Alpine:
unknown_versioning: *hls-64
Stack:
2.5.1:
viTags: []
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v251
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &stack-251-64
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz
dlHash: c83b6c93d6541c0bce2175085a04062020f4160a86116e20f3b343b562f2d1e8
dlSubdir:
RegexDir: "stack-.*"
Darwin:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz
dlHash: f4aedfa8fbe371f77286ee97ec5c3c553842e7ae15b2952a8b8442dccba04bf0
dlSubdir:
RegexDir: "stack-.*"
Linux_Alpine:
unknown_versioning: *stack-251-64
2.7.1:
viTags:
- Recommended
- Latest
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &stack-64
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
dlSubdir:
RegexDir: "stack-.*"
Darwin:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-osx-x86_64.tar.gz
dlHash: 4248c6fbc87e8a2c06f39e867eb5ef28eae0d99470137cb415356c631c0dcbf2
dlSubdir:
RegexDir: "stack-.*"
Linux_Alpine:
unknown_versioning: *stack-64

View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.14.1
version: 0.1.14.2
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020
@ -85,7 +85,6 @@ library
build-depends:
, aeson >=1.4 && <1.6
, ascii-string ^>=1.0
, async >=0.8 && <2.3
, base >=4.13 && <5
, base16-bytestring >=0.1.1.6 && <1.1

File diff suppressed because it is too large Load Diff

View File

@ -503,6 +503,115 @@ installHLSBin bDls ver pfreq = do
installHLSBindist dlinfo ver pfreq
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
-- creates a default @stack -> stack-x.y.z.q@ symlink for
-- the latest installed version.
installStackBin :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installStackBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo Stack ver pfreq bDls
installStackBindist dlinfo ver pfreq
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installStackBindist :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installStackBindist dlinfo ver PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
AppState {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installStack' workdir binDir
-- create symlink if this is the latest version
sVers <- lift $ fmap rights getInstalledStacks
let lInstStack = headMay . reverse . sort $ sVers
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
where
-- | Install an unpacked stack distribution.
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked stack bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installStack' path inst = do
lift $ $(logInfo) "Installing stack"
let stackFile = [rel|stack|]
liftIO $ createDirRecursive' inst
destFileName <- lift $ parseRel (toFilePath stackFile <> "-" <> verToBS ver)
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile)
destPath
Overwrite
lift $ chmod_755 destPath
---------------------
@ -681,6 +790,35 @@ setHLS ver = do
pure ()
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setStack ver = do
let verBS = verToBS ver
targetFile <- parseRel ("stack-" <> verBS)
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
liftIO $ createDirRecursive' binDir
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
let stackbin = binDir </> [rel|stack|]
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath stackbin}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile
stackbin
-- create symlink
let destL = toFilePath targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath stackbin}|]
liftIO $ createSymlink stackbin destL
pure ()
@ -738,15 +876,17 @@ listVersions av lt' criteria pfreq = do
cabals <- getInstalledCabals' cSet
hlsSet' <- hlsSet
hlses <- getInstalledHLSs
sSet <- stackSet
stacks <- getInstalledStacks
go lt' cSet cabals hlsSet' hlses
go lt' cSet cabals hlsSet' hlses sSet stacks
where
go lt cSet cabals hlsSet' hlses = do
go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of
Just t -> do
-- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses)
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
case t of
GHC -> do
@ -758,13 +898,17 @@ listVersions av lt' criteria pfreq = do
HLS -> do
slr <- strayHLS avTools
pure (sort (slr ++ lr))
Stack -> do
slr <- strayStacks avTools
pure (sort (slr ++ lr))
GHCup -> pure lr
Nothing -> do
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
@ -864,6 +1008,34 @@ listVersions av lt' criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayStacks avTools = do
stacks <- getInstalledStacks
fmap catMaybes $ forM stacks $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (== Just ver) hlsSet
pure $ Just $ ListResult
{ lTool = Stack
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Tool
@ -871,9 +1043,11 @@ listVersions av lt' criteria pfreq = do
-> [Either (Path Rel) Version]
-> Maybe Version
-> [Either (Path Rel) Version]
-> Maybe Version
-> [Either (Path Rel) Version]
-> (Version, [Tag])
-> m ListResult
toListResult t cSet cabals hlsSet' hlses (v, tags) = case t of
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
let tver = mkTVer v
@ -921,6 +1095,19 @@ listVersions av lt' criteria pfreq = do
, hlsPowered = False
, ..
}
Stack -> do
let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq av
let lSet = stackSet' == Just v
let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
filter' :: [ListResult] -> [ListResult]
@ -1038,6 +1225,28 @@ rmHLSVer ver = do
Nothing -> pure ()
-- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version).
rmStackVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmStackVer ver = do
whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
sSet <- lift stackSet
AppState {dirs = Dirs {..}} <- lift ask
stackFile <- lift $ parseRel ("stack-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> stackFile)
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(binDir </> [rel|stack|])
------------------

View File

@ -85,6 +85,7 @@ data Tool = GHC
| Cabal
| GHCup
| HLS
| Stack
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
@ -257,6 +258,7 @@ data UserKeyBindings = UserKeyBindings
, kSet :: Maybe Vty.Key
, kChangelog :: Maybe Vty.Key
, kShowAll :: Maybe Vty.Key
, kShowAllTools :: Maybe Vty.Key
}
deriving (Show, GHC.Generic)
@ -268,7 +270,8 @@ data KeyBindings = KeyBindings
, bUninstall :: Vty.Key
, bSet :: Vty.Key
, bChangelog :: Vty.Key
, bShowAll :: Vty.Key
, bShowAllVersions :: Vty.Key
, bShowAllTools :: Vty.Key
}
deriving (Show, GHC.Generic)
@ -281,7 +284,8 @@ defaultKeyBindings = KeyBindings
, bUninstall = Vty.KChar 'u'
, bSet = Vty.KChar 's'
, bChangelog = Vty.KChar 'c'
, bShowAll = Vty.KChar 'a'
, bShowAllVersions = Vty.KChar 'a'
, bShowAllTools = Vty.KChar 't'
}
data AppState = AppState

View File

@ -359,6 +359,54 @@ getInstalledHLSs = do
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^stack-.*$|] :: ByteString)
)
forM bins $ \f ->
case
fmap (version . decUTF8Safe) . B.stripPrefix "stack-" . toFilePath $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
stackSet = do
AppState {dirs = Dirs {..}} <- ask
let stackBin = binDir </> [rel|stack|]
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink stackBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath stackBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "stack-" *> version'
-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
stackInstalled ver = do
vers <- fmap rights getInstalledStacks
pure $ elem ver vers
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool