Compare commits

..

1 Commits

Author SHA1 Message Date
vglfr
1cfff674b7 Implement config CLI MVP 2021-08-03 09:09:47 +03:00
5 changed files with 237 additions and 240 deletions

View File

@@ -448,19 +448,19 @@ install' _ (_, ListResult {..}) = do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer Nothing $> vi
liftE $ installGHCBin lVer $> vi
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer Nothing $> vi
liftE $ installCabalBin lVer $> vi
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing $> vi
liftE $ installHLSBin lVer $> vi
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer Nothing $> vi
liftE $ installStackBin lVer $> vi
)
>>= \case
VRight vi -> do

View File

@@ -78,6 +78,8 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified Data.Yaml.Pretty as YP
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
@@ -105,6 +107,7 @@ data Command
| Rm (Either RmCommand RmOptions)
| DInfo
| Compile CompileCommand
| Config ConfigCommand
| Whereis WhereisOptions WhereisCommand
| Upgrade UpgradeOpts Bool
| ToolRequirements
@@ -138,7 +141,6 @@ data InstallOptions = InstallOptions
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
}
data SetCommand = SetGHC SetOptions
@@ -174,6 +176,8 @@ data RmOptions = RmOptions
data CompileCommand = CompileGHC GHCCompileOptions
data ConfigCommand = ShowConfig | SetConfig String String | InitConfig
data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: Either Version GitBranch
, bootstrapGhc :: Either Version FilePath
@@ -186,7 +190,6 @@ data GHCCompileOptions = GHCCompileOptions
, ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String
, hadrian :: Bool
, isolateDir :: Maybe FilePath
}
data UpgradeOpts = UpgradeInplace
@@ -410,6 +413,12 @@ com =
<> footerDoc (Just $ text changeLogFooter)
)
)
<> command
"config"
( Config
<$> info (configP <**> helper)
(progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
)
<> commandGroup "Other commands:"
<> hidden
)
@@ -484,6 +493,17 @@ Examples:
ghcup prefetch ghc 8.10.5
ghcup --offline install ghc 8.10.5|]
configFooter :: String
configFooter = [s|Examples:
# show current config
ghcup config
# initialize config
ghcup config init
# set <key> <value> configuration pair
ghcup config <key> <value>|]
installCabalFooter :: String
installCabalFooter = [s|Discussion:
@@ -576,7 +596,7 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b is -> InstallOptions v p u b is)
(\p (u, v) b -> InstallOptions v p u b)
<$> optional
(option
(eitherReader platformParser)
@@ -605,15 +625,6 @@ installOpts tool =
(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"
)
)
setParser :: Parser (Either SetCommand SetOptions)
@@ -797,6 +808,19 @@ Examples:
# 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|]
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")
whereisP :: Parser WhereisCommand
whereisP = subparser
@@ -1011,15 +1035,6 @@ ghcCompileOpts =
<*> 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"
)
)
toolVersionParser :: Parser ToolVersion
@@ -1235,10 +1250,6 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
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."
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings options = do
@@ -1282,6 +1293,27 @@ toSettings options = do
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
}
updateSettings :: UTF8.ByteString -> Settings -> IO Settings
updateSettings config settings = do
settings' <- runE @'[JSONError] $ lE' JSONDecodeError . first show . Y.decodeEither' $ config
case settings' of
VRight r -> pure $ mergeConf r settings
VLeft (V (JSONDecodeError e)) -> do
B.hPut stderr ("Error decoding config: " <> (E.encodeUtf8 . T.pack . show $ e))
die ""
_ -> die "Unexpected error!"
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
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork'
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
@@ -1316,6 +1348,12 @@ describe_result = $( LitE . StringL <$>
)
)
formatConfig :: Settings -> KeyBindings -> String
formatConfig settings keybindings = unlines [formatSettings, formatKeybindings]
where
formatKeybindings = unlines . ("key-bindings:":) . map (" "++) . lines . UTF8.toString . YP.encodePretty yamlConfig $ keybindings
formatSettings = UTF8.toString . YP.encodePretty yamlConfig $ settings
yamlConfig = YP.setConfCompare compare YP.defConfig
main :: IO ()
main = do
@@ -1641,23 +1679,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-----------------------
let installGHC InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v) isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
liftE $ installGHCBin (_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
Just uri -> do
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "GHC installation successful"
@@ -1686,7 +1723,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) isolateDir
liftE $ installCabalBin (_tvVersion v)
pure vi
Just uri -> do
s' <- appState
@@ -1695,7 +1732,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
)
>>= \case
@@ -1715,10 +1751,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
(case instBindist of
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) isolateDir
liftE $ installHLSBin (_tvVersion v)
pure vi
Just uri -> do
s' <- appState
@@ -1727,7 +1763,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
)
>>= \case
@@ -1747,20 +1782,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4
let installStack InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) isolateDir
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v)
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
)
>>= \case
VRight vi -> do
@@ -1989,7 +2023,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
addConfArgs
buildFlavour
hadrian
isolateDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
@@ -2019,6 +2052,28 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 9
Config InitConfig -> do
path <- getConfigFilePath
writeFile path $ formatConfig settings keybindings
runLogger $ $(logDebug) [i|"config.yaml initialized at #{path}|]
pure ExitSuccess
Config ShowConfig -> do
putStrLn $ formatConfig settings keybindings
pure ExitSuccess
Config (SetConfig k v) -> do
case v of
"" -> die "Empty values are not allowed."
_ -> do
settings' <- updateSettings [i|#{k}: #{v}\n|] settings
runLogger $ $(logDebug) $ T.pack $ show settings'
path <- getConfigFilePath
writeFile path $ formatConfig settings' keybindings
pure ExitSuccess
Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
runLeanWhereIs (do
loc <- liftE $ whereIsTool tool v

View File

@@ -226,6 +226,7 @@ executable ghcup
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, versions >=4.0.1 && <5.1
, yaml ^>=0.11.4.0
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER

View File

@@ -186,7 +186,6 @@ installGHCBindist :: ( MonadFail m
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated filepath if user passed any
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -202,15 +201,10 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver isoFilepath = do
installGHCBindist dlinfo ver = do
let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs
Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
_ -> pure ()
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -218,16 +212,11 @@ installGHCBindist dlinfo ver isoFilepath = do
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|]
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
Nothing -> do -- regular install
toolchainSanityChecks
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
toolchainSanityChecks
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver
liftE $ postGHCInstall tver
where
toolchainSanityChecks = do
@@ -354,7 +343,6 @@ installGHCBin :: ( MonadFail m
, MonadUnliftIO m
)
=> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -370,9 +358,9 @@ installGHCBin :: ( MonadFail m
]
m
()
installGHCBin ver isoFilepath = do
installGHCBin ver = do
dlinfo <- liftE $ getDownloadInfo GHC ver
installGHCBindist dlinfo ver isoFilepath
installGHCBindist dlinfo ver
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@@ -391,7 +379,6 @@ installCabalBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any.
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -407,24 +394,20 @@ installCabalBindist :: ( MonadMask m
]
m
()
installCabalBindist dlinfo ver isoFilepath = do
installCabalBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
case isoFilepath of
Nothing -> -- for regular install check if any previous versions installed
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
_ -> pure () -- check isn't required in isolated installs
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -437,35 +420,30 @@ installCabalBindist dlinfo ver isoFilepath = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|]
liftE $ installCabalUnpacked workdir isoDir ver
liftE $ installCabal' workdir binDir
Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir ver
-- create symlink if this is the latest version
cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- create symlink if this is the latest version for regular installs
cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
where
-- | Install an unpacked cabal distribution.
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installCabal' path inst = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt)
destPath
lift $ chmod_755 destPath
-- | Install an unpacked cabal distribution.
installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Version
-> Excepts '[CopyError] m ()
installCabalUnpacked path inst ver = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt)
destPath
lift $ chmod_755 destPath
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
@@ -484,7 +462,6 @@ installCabalBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath -- isolated install Path, if user provided any
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -500,9 +477,9 @@ installCabalBin :: ( MonadMask m
]
m
()
installCabalBin ver isoFilepath = do
installCabalBin ver = do
dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver isoFilepath
installCabalBindist dlinfo ver
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@@ -521,7 +498,6 @@ installHLSBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -537,19 +513,14 @@ installHLSBindist :: ( MonadMask m
]
m
()
installHLSBindist dlinfo ver isoFilepath = do
installHLSBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
case isoFilepath of
Nothing ->
-- we only check for already installed in regular (non-isolated) installs
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
_ -> pure ()
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -562,52 +533,46 @@ installHLSBindist dlinfo ver isoFilepath = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of
Just isoDir -> do
lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|]
liftE $ installHLSUnpacked workdir isoDir ver
liftE $ installHLS' workdir binDir
Nothing -> do
liftE $ installHLSUnpacked workdir binDir ver
-- create symlink if this is the latest version
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
where
-- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installHLS' path inst = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> "~" <> T.unpack (prettyVer ver) <> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Version
-> Excepts '[CopyError] m ()
installHLSUnpacked path inst ver = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> "~" <> T.unpack (prettyVer ver) <> exeExt
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(path </> wrapper <> exeExt)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper <> exeExt)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
@@ -625,7 +590,6 @@ installHLSBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -641,9 +605,9 @@ installHLSBin :: ( MonadMask m
]
m
()
installHLSBin ver isoFilepath = do
installHLSBin ver = do
dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver isoFilepath
installHLSBindist dlinfo ver
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
@@ -663,7 +627,6 @@ installStackBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -679,9 +642,9 @@ installStackBin :: ( MonadMask m
]
m
()
installStackBin ver isoFilepath = do
installStackBin ver = do
dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver isoFilepath
installStackBindist dlinfo ver
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
@@ -700,7 +663,6 @@ installStackBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -716,18 +678,14 @@ installStackBindist :: ( MonadMask m
]
m
()
installStackBindist dlinfo ver isoFilepath = do
installStackBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
case isoFilepath of
Nothing -> -- check previous versions in case of regular installs
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
_ -> pure () -- don't do shit for isolates
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -740,35 +698,31 @@ installStackBindist dlinfo ver isoFilepath = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|]
liftE $ installStackUnpacked workdir isoDir ver
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir ver
liftE $ installStack' workdir binDir
-- create symlink if this is the latest version and a regular install
sVers <- lift $ fmap rights getInstalledStacks
let lInstStack = headMay . reverse . sort $ sVers
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
-- 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)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installStack' path inst = do
lift $ $(logInfo) "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt)
destPath
lift $ chmod_755 destPath
-- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Version
-> Excepts '[CopyError] m ()
installStackUnpacked path inst ver = do
lift $ $(logInfo) "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt)
destPath
lift $ chmod_755 destPath
---------------------
@@ -1750,7 +1704,6 @@ compileGHC :: ( MonadMask m
-> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour
-> Bool
-> Maybe FilePath -- ^ isolate dir
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -1769,7 +1722,7 @@ compileGHC :: ( MonadMask m
]
m
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian
= do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -1839,18 +1792,12 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
when alreadyInstalled $ do
case isolateDir of
Just isoDir ->
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Isolate installing to #{isoDir} |]
Nothing ->
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
lift $ $(logWarn)
"...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
ghcdir <- case isolateDir of
Just isoDir -> pure isoDir
Nothing -> lift $ ghcupGHCDir installVer
ghcdir <- lift $ ghcupGHCDir installVer
bghc <- case bstrap of
Right g -> pure $ Right g
@@ -1867,14 +1814,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
pure (b, bmk)
)
case isolateDir of
Nothing ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
_ -> pure ()
when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
forM_ mBindist $ \bindist -> do
liftE $ installPackedGHC bindist
@@ -1883,15 +1825,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(tver ^. tvVersion)
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
case isolateDir of
-- set and make symlinks for regular (non-isolated) installs
Nothing -> do
reThrowAll GHCupSetError $ postGHCInstall tver
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
_ -> pure ()
reThrowAll GHCupSetError $ postGHCInstall tver
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
pure tver

View File

@@ -316,3 +316,6 @@ deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key