hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add stack support

Browse Source
This commit is contained in:
Julian Ospald
2021-05-15 00:31:36 +02:00
parent 5f6ed1292d
commit 734916728c
10 changed files with 19221 additions and 18464 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
app/ghcup/BrickMain.hs
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)

125
app/ghcup/Main.hs
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