diff --git a/CHANGELOG.md b/CHANGELOG.md index 38ae547..95ab981 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,7 @@ - reverse list order so latest is on top - expand the blues selected bar - show new latest versions in bright white +* allow configuration file and settings TUI hotkeys wrt #41 ## 0.1.11 -- 2020-09-23 diff --git a/README.md b/README.md index 06dd598..16107d0 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p * [Manual install](#manual-install) * [Vim integration](#vim-integration) * [Usage](#usage) + * [Configuration](#configuration) * [Manpages](#manpages) * [Shell-completion](#shell-completion) * [Cross support](#cross-support) @@ -80,6 +81,13 @@ ghcup upgrade Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do. +### Configuration + +A configuration file can be put in `~/.ghcup/config.yaml`. The default config file +explaining all possible configurations can be found in this repo: [config.yaml](./config.yaml). + +Partial configuration is fine. Command line options always overwrite the config file settings. + ### Manpages For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc. diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index f54eb97..38a6e39 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -193,7 +193,7 @@ validateTarballs dls = do where downloadAll dli = do dirs <- liftIO getDirs - let settings = Settings True False Never Curl False dirs + let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True , colorOutter = B.hPut stderr , rawOutter = (\_ -> pure ()) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index b3b40d1..b4d0fee 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -36,7 +36,6 @@ import Data.Bool import Data.Functor import Data.List import Data.Maybe -import Data.Char import Data.IORef import Data.String.Interpolate import Data.Vector ( Vector @@ -55,59 +54,70 @@ import qualified Data.Vector as V -data AppData = AppData +data BrickData = BrickData { lr :: [ListResult] , dls :: GHCupDownloads , pfreq :: PlatformRequest } deriving Show -data AppSettings = AppSettings +data BrickSettings = BrickSettings { showAll :: Bool } deriving Show -data AppInternalState = AppInternalState +data BrickInternalState = BrickInternalState { clr :: Vector ListResult , ix :: Int } deriving Show -data AppState = AppState - { appData :: AppData - , appSettings :: AppSettings - , appState :: AppInternalState +data BrickState = BrickState + { appData :: BrickData + , appSettings :: BrickSettings + , appState :: BrickInternalState + , appKeys :: KeyBindings } deriving Show -keyHandlers :: [ ( Char - , AppSettings -> String - , AppState -> EventM n (Next AppState) +keyHandlers :: KeyBindings + -> [ ( Vty.Key + , BrickSettings -> String + , BrickState -> EventM n (Next BrickState) ) ] -keyHandlers = - [ ('q', const "Quit" , halt) - , ('i', const "Install" , withIOAction install') - , ('u', const "Uninstall", withIOAction del') - , ('s', const "Set" , withIOAction set') - , ('c', const "ChangeLog", withIOAction changelog') - , ( 'a' - , (\AppSettings {..} -> +keyHandlers KeyBindings {..} = + [ (bQuit, const "Quit" , halt) + , (bInstall, const "Install" , withIOAction install') + , (bUninstall, const "Uninstall", withIOAction del') + , (bSet, const "Set" , withIOAction set') + , (bChangelog, const "ChangeLog", withIOAction changelog') + , ( bShowAll + , (\BrickSettings {..} -> if showAll then "Hide old versions" else "Show all versions" ) , hideShowHandler ) + , (bUp, const "Up", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Up), .. })) + , (bDown, const "Down", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Down), .. })) ] where - hideShowHandler (AppState {..}) = + hideShowHandler (BrickState {..}) = let newAppSettings = appSettings { showAll = not . showAll $ appSettings } newInternalState = constructList appData newAppSettings (Just appState) - in continue (AppState appData newAppSettings newInternalState) + in continue (BrickState appData newAppSettings newInternalState appKeys) -ui :: AppState -> Widget String -ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} +showKey :: Vty.Key -> String +showKey (Vty.KChar c) = [c] +showKey (Vty.KUp) = "↑" +showKey (Vty.KDown) = "↓" +showKey key = tail (show key) + + +ui :: BrickState -> Widget String +ui BrickState { appSettings = as@(BrickSettings {}), ..} = ( padBottom Max $ ( withBorderStyle unicode $ borderWithLabel (str "GHCup") @@ -122,8 +132,7 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} . txtWrap . T.pack . foldr1 (\x y -> x <> " " <> y) - . (++ ["↑↓:Navigation"]) - $ (fmap (\(c, s, _) -> (c : ':' : s as)) keyHandlers) + $ (fmap (\(key, s, _) -> (showKey key <> ":" <> s as)) $ keyHandlers appKeys) header = (minHSize 2 $ emptyWidget) <+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool") @@ -196,9 +205,9 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} -- available height. drawListElements :: (Int -> Bool -> ListResult -> Widget String) -> Bool - -> AppInternalState + -> BrickInternalState -> Widget String - drawListElements drawElem foc is@(AppInternalState clr _) = + drawListElements drawElem foc is@(BrickInternalState clr _) = Widget Greedy Greedy $ let es = clr @@ -228,7 +237,7 @@ minHSize :: Int -> Widget n -> Widget n minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') -app :: App AppState e String +app :: App BrickState e String app = App { appDraw = \st -> [ui st] , appHandleEvent = eventHandler , appStartEvent = return @@ -261,34 +270,40 @@ dimAttributes = attrMap , ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) ] -eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState) -eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st -eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st -eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st -eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = - continue (AppState { appState = (moveCursor appState Up), .. }) -eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = - continue (AppState { appState = (moveCursor appState Down), .. }) -eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = - case find (\(c', _, _) -> c' == c) keyHandlers of - Nothing -> continue as - Just (_, _, handler) -> handler as -eventHandler st _ = continue st + +eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState) +eventHandler st@(BrickState {..}) ev = do + AppState { keyBindings = kb } <- liftIO $ readIORef settings' + case ev of + (MouseDown _ Vty.BScrollUp _ _) -> + continue (BrickState { appState = moveCursor 1 appState Up, .. }) + (MouseDown _ Vty.BScrollDown _ _) -> + continue (BrickState { appState = moveCursor 1 appState Down, .. }) + (VtyEvent (Vty.EvResize _ _)) -> continue st + (VtyEvent (Vty.EvKey Vty.KUp _)) -> + continue (BrickState { appState = (moveCursor 1 appState Up), .. }) + (VtyEvent (Vty.EvKey Vty.KDown _)) -> + continue (BrickState { appState = (moveCursor 1 appState Down), .. }) + (VtyEvent (Vty.EvKey key _)) -> + case find (\(key', _, _) -> key' == key) (keyHandlers kb) of + Nothing -> continue st + Just (_, _, handler) -> handler st + _ -> continue st -moveCursor :: AppInternalState -> Direction -> AppInternalState -moveCursor ais@(AppInternalState {..}) direction = - let newIx = if direction == Down then ix + 1 else ix - 1 +moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState +moveCursor steps ais@(BrickInternalState {..}) direction = + let newIx = if direction == Down then ix + steps else ix - steps in case clr !? newIx of - Just _ -> AppInternalState { ix = newIx, .. } + Just _ -> BrickInternalState { ix = newIx, .. } Nothing -> ais -- | Suspend the current UI and run an IO action in terminal. If the -- IO action returns a Left value, then it's thrown as userError. -withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a)) - -> AppState - -> EventM n (Next AppState) +withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a)) + -> BrickState + -> EventM n (Next BrickState) withIOAction action as = case listSelectedElement' (appState as) of Nothing -> continue as Just (ix, e) -> suspendAndResume $ do @@ -304,26 +319,27 @@ withIOAction action as = case listSelectedElement' (appState as) of -- | Update app data and list internal state based on new evidence. --- This synchronises @AppInternalState@ with @AppData@ --- and @AppSettings@. -updateList :: AppData -> AppState -> AppState -updateList appD (AppState {..}) = +-- This synchronises @BrickInternalState@ with @BrickData@ +-- and @BrickSettings@. +updateList :: BrickData -> BrickState -> BrickState +updateList appD (BrickState {..}) = let newInternalState = constructList appD appSettings (Just appState) - in AppState { appState = newInternalState - , appData = appD - , appSettings = appSettings - } + in BrickState { appState = newInternalState + , appData = appD + , appSettings = appSettings + , appKeys = appKeys + } -constructList :: AppData - -> AppSettings - -> Maybe AppInternalState - -> AppInternalState +constructList :: BrickData + -> BrickSettings + -> Maybe BrickInternalState + -> BrickInternalState constructList appD appSettings mapp = replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp -listSelectedElement' :: AppInternalState -> Maybe (Int, ListResult) -listSelectedElement' (AppInternalState {..}) = fmap (ix, ) $ clr !? ix +listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult) +listSelectedElement' (BrickInternalState {..}) = fmap (ix, ) $ clr !? ix selectLatest :: Vector ListResult -> Int @@ -338,8 +354,8 @@ selectLatest v = -- When passed an existing @appState@, tries to keep the selected element. replaceLR :: (ListResult -> Bool) -> [ListResult] - -> Maybe AppInternalState - -> AppInternalState + -> Maybe BrickInternalState + -> BrickInternalState replaceLR filterF lr s = let oldElem = s >>= listSelectedElement' newVec = V.fromList . filter filterF $ lr @@ -347,7 +363,7 @@ replaceLR filterF lr s = case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of Just ix -> ix Nothing -> selectLatest newVec - in AppInternalState newVec newSelected + in BrickInternalState newVec newSelected where toolEqual e1 e2 = lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 @@ -359,8 +375,8 @@ filterVisible showAll e | lInstalled e = True | otherwise = not (elem Old (lTag e)) -install' :: AppState -> (Int, ListResult) -> IO (Either String ()) -install' AppState { appData = AppData {..} } (_, ListResult {..}) = do +install' :: BrickState -> (Int, ListResult) -> IO (Either String ()) +install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do settings <- readIORef settings' l <- readIORef logger' let runLogger = myLoggerT l @@ -406,7 +422,7 @@ install' AppState { appData = AppData {..} } (_, ListResult {..}) = do Also check the logs in ~/.ghcup/logs|] -set' :: AppState -> (Int, ListResult) -> IO (Either String ()) +set' :: BrickState -> (Int, ListResult) -> IO (Either String ()) set' _ (_, ListResult {..}) = do settings <- readIORef settings' l <- readIORef logger' @@ -429,7 +445,7 @@ set' _ (_, ListResult {..}) = do VLeft e -> pure $ Left [i|#{e}|] -del' :: AppState -> (Int, ListResult) -> IO (Either String ()) +del' :: BrickState -> (Int, ListResult) -> IO (Either String ()) del' _ (_, ListResult {..}) = do settings <- readIORef settings' l <- readIORef logger' @@ -449,8 +465,8 @@ del' _ (_, ListResult {..}) = do VLeft e -> pure $ Left [i|#{e}|] -changelog' :: AppState -> (Int, ListResult) -> IO (Either String ()) -changelog' AppState { appData = AppData {..} } (_, ListResult {..}) = do +changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ()) +changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do case getChangeLog dls lTool (Left lVer) of Nothing -> pure $ Left [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|] @@ -469,17 +485,21 @@ uri' :: IORef (Maybe URI) uri' = unsafePerformIO (newIORef Nothing) -settings' :: IORef Settings +settings' :: IORef AppState {-# NOINLINE settings' #-} settings' = unsafePerformIO $ do dirs <- getDirs - newIORef Settings { cache = True - , noVerify = False - , keepDirs = Never - , downloader = Curl - , verbose = False - , .. - } + newIORef $ AppState (Settings { cache = True + , noVerify = False + , keepDirs = Never + , downloader = Curl + , verbose = False + , urlSource = GHCupURL + , .. + }) + dirs + defaultKeyBindings + logger' :: IORef LoggerConfig @@ -492,7 +512,7 @@ logger' = unsafePerformIO ) -brickMain :: Settings +brickMain :: AppState -> Maybe URI -> LoggerConfig -> GHCupDownloads @@ -510,9 +530,11 @@ brickMain s muri l av pfreq' = do Right ad -> defaultMain app - (AppState ad + (BrickState ad defaultAppSettings (constructList ad defaultAppSettings Nothing) + (keyBindings s) + ) $> () Left e -> do @@ -520,8 +542,8 @@ brickMain s muri l av pfreq' = do exitWith $ ExitFailure 2 -defaultAppSettings :: AppSettings -defaultAppSettings = AppSettings { showAll = False } +defaultAppSettings :: BrickSettings +defaultAppSettings = BrickSettings { showAll = False } getDownloads' :: IO (Either String GHCupDownloads) @@ -546,7 +568,7 @@ getDownloads' = do getAppData :: Maybe GHCupDownloads -> PlatformRequest - -> IO (Either String AppData) + -> IO (Either String BrickData) getAppData mg pfreq' = do settings <- readIORef settings' l <- readIORef logger' @@ -558,6 +580,6 @@ getAppData mg pfreq' = do case r of Right dls -> do lV <- listVersions dls Nothing Nothing pfreq' - pure $ Right $ (AppData (reverse lV) dls pfreq') + pure $ Right $ (BrickData (reverse lV) dls pfreq') Left e -> pure $ Left [i|#{e}|] diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index ec67ce1..beff0df 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -81,12 +81,12 @@ import qualified Text.Megaparsec.Char as MPC data Options = Options { -- global options - optVerbose :: Bool - , optCache :: Bool + optVerbose :: Maybe Bool + , optCache :: Maybe Bool , optUrlSource :: Maybe URI - , optNoVerify :: Bool - , optKeepDirs :: KeepDirs - , optsDownloader :: Downloader + , optNoVerify :: Maybe Bool + , optKeepDirs :: Maybe KeepDirs + , optsDownloader :: Maybe Downloader -- commands , optCommand :: Command } @@ -122,6 +122,7 @@ data InstallOptions = InstallOptions { instVer :: Maybe ToolVersion , instPlatform :: Maybe PlatformRequest , instBindist :: Maybe URI + , instSet :: Bool } data SetCommand = SetGHC SetOptions @@ -158,6 +159,7 @@ data GHCCompileOptions = GHCCompileOptions , patchDir :: Maybe (Path Abs) , crossTarget :: Maybe Text , addConfArgs :: [Text] + , setCompile :: Bool } data CabalCompileOptions = CabalCompileOptions @@ -180,13 +182,48 @@ data ChangeLogOptions = ChangeLogOptions } +-- 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 + + opts :: Parser Options opts = Options - <$> switch (short 'v' <> long "verbose" <> help "Enable verbosity") - <*> switch - (short 'c' <> long "cache" <> help "Cache downloads in ~/.ghcup/cache" - ) + <$> 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) @@ -198,35 +235,29 @@ opts = ) ) ) - <*> switch - (short 'n' <> long "no-verify" <> help - "Skip tarball checksum verification" - ) - <*> option + <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)")) + <*> optional (option (eitherReader keepOnParser) ( long "keep" <> metavar "" <> help "Keep build directories? (default: errors)" - <> value Errors <> hidden - ) - <*> option + )) + <*> optional (option (eitherReader downloaderParser) ( long "downloader" #if defined(INTERNAL_DOWNLOADER) <> metavar "" <> help "Downloader to use (default: internal)" - <> value Internal #else <> metavar "" <> help "Downloader to use (default: curl)" - <> value Curl #endif <> hidden - ) + )) <*> com where parseUri s' = @@ -343,20 +374,20 @@ com = 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' or 'cabal').|] + It is recommended to always specify a subcommand (ghc/cabal/hls).|] 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' or 'cabal').|] + It is recommended to always specify a subcommand (ghc/cabal/hls).|] 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' or 'cabal').|] + It is recommended to always specify a subcommand (ghc/cabal/hls).|] changeLogFooter :: String changeLogFooter = [s|Discussion: @@ -441,7 +472,7 @@ Examples: installOpts :: Parser InstallOptions installOpts = - (\p (u, v) -> InstallOptions v p u) + (\p (u, v) b -> InstallOptions v p u b) <$> (optional (option (eitherReader platformParser) @@ -466,6 +497,12 @@ installOpts = ) <|> ((,) <$> pure Nothing <*> optional toolVersionArgument) ) + <*> flag + False + True + (long "set" <> help + "Set as active version after install" + ) setParser :: Parser (Either SetCommand SetOptions) @@ -635,7 +672,7 @@ Examples: ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = - (\CabalCompileOptions {..} crossTarget addConfArgs -> GHCCompileOptions { .. } + (\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. } ) <$> cabalCompileOpts <*> (optional @@ -647,6 +684,12 @@ ghcCompileOpts = ) ) <*> 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" + ) cabalCompileOpts :: Parser CabalCompileOptions cabalCompileOpts = @@ -856,15 +899,46 @@ bindistParser :: String -> Either String URI bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString -toSettings :: Options -> IO Settings -toSettings Options {..} = do - let cache = optCache - noVerify = optNoVerify - keepDirs = optKeepDirs - downloader = optsDownloader - verbose = optVerbose +toSettings :: Options -> IO AppState +toSettings options = do dirs <- getDirs - pure $ Settings { .. } + userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case + VRight r -> pure r + VLeft (V (JSONDecodeError e)) -> do + B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e)) + pure defaultUserSettings + _ -> do + die "Unexpected error!" + pure $ mergeConf options dirs userConf + where + mergeConf :: Options -> Dirs -> UserSettings -> AppState + mergeConf (Options {..}) dirs (UserSettings {..}) = + let cache = fromMaybe (fromMaybe False uCache) optCache + noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify + verbose = fromMaybe (fromMaybe False uVerbose) optVerbose + keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs + downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader + keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings + urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource + in AppState (Settings {..}) dirs keyBindings +#if defined(INTERNAL_DOWNLOADER) + defaultDownloader = Internal +#else + defaultDownloader = Curl +#endif + mergeKeys :: UserKeyBindings -> KeyBindings + mergeKeys UserKeyBindings {..} = + let KeyBindings {..} = defaultKeyBindings + in KeyBindings { + bUp = fromMaybe bUp kUp + , bDown = fromMaybe bDown kDown + , bQuit = fromMaybe bQuit kQuit + , bInstall = fromMaybe bInstall kInstall + , bUninstall = fromMaybe bUninstall kUninstall + , bSet = fromMaybe bSet kSet + , bChangelog = fromMaybe bChangelog kChangelog + , bShowAll = fromMaybe bShowAll kShowAll + } upgradeOptsP :: Parser UpgradeOpts @@ -931,6 +1005,7 @@ main = do ENV variables: * TMPDIR: where ghcup does the work (unpacking, building, ...) * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) + * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories Report bugs at |] @@ -940,15 +1015,15 @@ Report bugs at |] (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do - settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt + appstate@AppState{dirs = Dirs{..}, ..} <- toSettings opt -- create ~/.ghcup dir createDirRecursive' baseDir -- logger interpreter - logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|] + logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|] let loggerConfig = LoggerConfig - { lcPrintDebug = optVerbose + { lcPrintDebug = verbose settings , colorOutter = B.hPut stderr , rawOutter = appendFile logfile } @@ -959,9 +1034,9 @@ Report bugs at |] -- Effect interpreters -- ------------------------- - let runInstTool' settings' = + let runInstTool' appstate' = runLogger - . flip runReaderT settings' + . flip runReaderT appstate' . runResourceT . runE @'[ AlreadyInstalled @@ -980,12 +1055,12 @@ Report bugs at |] , TarDirDoesNotExist ] - let runInstTool = runInstTool' settings + let runInstTool = runInstTool' appstate let runSetGHC = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[ FileDoesNotExistError , NotInstalled @@ -995,7 +1070,7 @@ Report bugs at |] let runSetCabal = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[ NotInstalled , TagNotFound @@ -1004,26 +1079,26 @@ Report bugs at |] let runSetHLS = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[ NotInstalled , TagNotFound ] - let runListGHC = runLogger . flip runReaderT settings + let runListGHC = runLogger . flip runReaderT appstate let runRm = - runLogger . flip runReaderT settings . runE @'[NotInstalled] + runLogger . flip runReaderT appstate . runE @'[NotInstalled] let runDebugInfo = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] let runCompileGHC = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runResourceT . runE @'[ AlreadyInstalled @@ -1044,7 +1119,7 @@ Report bugs at |] let runUpgrade = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runResourceT . runE @'[ DigestError @@ -1072,10 +1147,10 @@ Report bugs at |] (GHCupInfo treq dls) <- ( runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE - $ getDownloadsF (maybe GHCupURL OwnSource optUrlSource) + $ getDownloadsF (urlSource settings) ) >>= \case VRight r -> pure r @@ -1086,7 +1161,7 @@ Report bugs at |] case optCommand of Upgrade _ _ -> pure () - _ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq + _ -> runLogger $ flip runReaderT appstate $ checkForUpdates dls pfreq @@ -1099,12 +1174,14 @@ Report bugs at |] Nothing -> runInstTool $ do v <- liftE $ fromVersion dls instVer GHC liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) - Just uri -> runInstTool' settings{noVerify = True} $ do + when instSet $ void $ liftE $ setGHC v SetGHCOnly + Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do v <- liftE $ fromVersion dls instVer GHC liftE $ installGHCBindist (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (_tvVersion v) (fromMaybe pfreq instPlatform) + when instSet $ void $ liftE $ setGHC v SetGHCOnly ) >>= \case VRight _ -> do @@ -1115,7 +1192,7 @@ Report bugs at |] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - case keepDirs of + case keepDirs settings of Never -> runLogger ($(logError) [i|Build failed with #{e}|]) _ -> runLogger ($(logError) [i|Build failed with #{e} Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues. @@ -1140,7 +1217,7 @@ Report bugs at |] Nothing -> runInstTool $ do v <- liftE $ fromVersion dls instVer Cabal liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) - Just uri -> runInstTool' settings{noVerify = True} $ do + Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do v <- liftE $ fromVersion dls instVer Cabal liftE $ installCabalBindist (DownloadInfo uri Nothing "") @@ -1173,7 +1250,7 @@ Report bugs at |] Nothing -> runInstTool $ do v <- liftE $ fromVersion dls instVer HLS liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) - Just uri -> runInstTool' settings{noVerify = True} $ do + Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do v <- liftE $ fromVersion dls instVer HLS liftE $ installHLSBindist (DownloadInfo uri Nothing "") @@ -1272,7 +1349,7 @@ Report bugs at |] res <- case optCommand of #if defined(BRICK) - Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess + Interactive -> liftIO $ brickMain appstate optUrlSource loggerConfig dls pfreq >> pure ExitSuccess #endif Install (Right iopts) -> do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) @@ -1317,14 +1394,17 @@ Report bugs at |] pure $ ExitFailure 8 Compile (CompileGHC GHCCompileOptions {..}) -> - (runCompileGHC $ liftE $ compileGHC dls - (GHCTargetVersion crossTarget targetVer) - bootstrapGhc - jobs - buildConfig - patchDir - addConfArgs - pfreq + (runCompileGHC $ do + liftE $ compileGHC dls + (GHCTargetVersion crossTarget targetVer) + bootstrapGhc + jobs + buildConfig + patchDir + addConfArgs + pfreq + when setCompile $ void $ liftE + $ setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly ) >>= \case VRight _ -> do @@ -1336,7 +1416,7 @@ Report bugs at |] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - case keepDirs of + case keepDirs settings of Never -> runLogger ($(logError) [i|Build failed with #{e} Check the logs at #{logsDir}|]) _ -> runLogger ($(logError) [i|Build failed with #{e} @@ -1602,7 +1682,14 @@ printListResult raw lr = do | otherwise -> 1 -checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) +checkForUpdates :: ( MonadReader AppState m + , MonadCatch m + , MonadLogger m + , MonadThrow m + , MonadIO m + , MonadFail m + , MonadLogger m + ) => GHCupDownloads -> PlatformRequest -> m () diff --git a/cabal.ghc884.project b/cabal.ghc884.project index d197b12..1efe554 100644 --- a/cabal.ghc884.project +++ b/cabal.ghc884.project @@ -1,6 +1,6 @@ -- Generated by stackage-to-hackage -index-state: 2020-10-05T20:10:01Z +index-state: 2020-10-24T20:53:55Z with-compiler: ghc-8.8.4 @@ -16,17 +16,12 @@ source-repository-package tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42 subdir: haskus-utils-types -source-repository-package - type: git - location: https://github.com/hasufell/hpath.git - tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2 - subdir: hpath-io - source-repository-package type: git location: https://github.com/hasufell/hpath.git tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2 subdir: hpath-directory + hpath-io source-repository-package type: git diff --git a/cabal.ghc884.project.freeze b/cabal.ghc884.project.freeze index d6cf576..3ac4943 100644 --- a/cabal.ghc884.project.freeze +++ b/cabal.ghc884.project.freeze @@ -373,7 +373,7 @@ constraints: any.AC-Angle ==1.0, any.bower-json ==1.0.0.1, any.boxes ==0.1.5, brick +demos, - any.brick ==0.52.1, + any.brick ==0.55, any.brittany ==0.12.1.1, any.broadcast-chan ==0.2.1.1, any.brotli ==0.0.0.0, @@ -927,6 +927,7 @@ constraints: any.AC-Angle ==1.0, any.ghci-hexcalc ==0.1.1.0, any.ghcid ==0.8.7, any.ghcjs-codemirror ==0.0.0.2, + ghcup +internal-downloader +tui, any.ghost-buster ==0.1.1.0, any.gi-atk ==2.0.21, any.gi-cairo ==1.0.23, @@ -2386,12 +2387,12 @@ constraints: any.AC-Angle ==1.0, any.vector-split ==1.0.0.2, any.vector-th-unbox ==0.2.1.7, any.verbosity ==0.4.0.0, - any.versions ==3.5.4, + any.versions ==4.0.1, any.vformat ==0.14.1.0, any.vformat-aeson ==0.1.0.1, any.vformat-time ==0.1.0.0, any.void ==0.7.3, - any.vty ==5.28.2, + any.vty ==5.30, any.wai ==3.2.2.1, any.wai-app-static ==3.1.7.2, any.wai-conduit ==3.0.0.4, diff --git a/config.yaml b/config.yaml new file mode 100644 index 0000000..cb98934 --- /dev/null +++ b/config.yaml @@ -0,0 +1,61 @@ +# Cache downloads in ~/.ghcup/cache +cache: False +# Skip tarball checksum verification +no-verify: False +# enable verbosity +verbose: False +# When to keep build directories +keep-dirs: Errors # Always | Never | Errors +# Which downloader to use +downloader: Curl # Curl | Wget | Internal + +# TUI key bindings, +# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key +# for possible values. +key-bindings: + up: + KUp: [] + down: + KDown: [] + quit: + KChar: 'q' + install: + KChar: 'i' + uninstall: + KChar: 'u' + set: + KChar: 's' + changelog: + KChar: 'c' + show-all: + KChar: 'a' + +# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation +# check the 'URLSource' type in the code. +url-source: + ## Use the internal download uri, this is the default + GHCupURL: [] + + ## Example 1: Read download info from this location instead + ## Accepts file/http/https scheme + # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml" + + ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions + # AddSource: + # Left: + # toolRequirements: {} # this is ignored + # ghcupDownloads: + # GHC: + # 9.10.2: + # viTags: [] + # viArch: + # A_64: + # Linux_UnknownLinux: + # unknown_versioning: + # dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2 + # dlSubdir: ghc-7.10.3 + # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5 + + ## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions + # AddSource: + # Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" diff --git a/ghcup.cabal b/ghcup.cabal index 7032da8..a2a2f77 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -72,6 +72,9 @@ common bz2 common case-insensitive build-depends: case-insensitive >=1.2.1.0 +common casing + build-depends: casing >=0.1.4.1 + common concurrent-output build-depends: concurrent-output >=1.10.11 @@ -226,7 +229,7 @@ common vector build-depends: vector >=0.12 common versions - build-depends: versions >=3.5 + build-depends: versions >=4.0.1 common vty build-depends: vty >=5.28.2 @@ -266,6 +269,7 @@ library , bytestring , bz2 , case-insensitive + , casing , concurrent-output , containers , cryptohash-sha256 @@ -307,6 +311,7 @@ library , utf8-string , vector , versions + , vty , word8 , yaml , zlib diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 75e3c20..e2a71c9 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -99,7 +99,7 @@ import qualified Data.Text.Encoding as E installGHCBindist :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -142,7 +142,7 @@ installGHCBindist dlinfo ver pfreq = do -- build system and nothing else. installPackedGHC :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -178,7 +178,7 @@ installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do -- | Install an unpacked GHC distribution. This only deals with the GHC -- build system and nothing else. -installUnpackedGHC :: ( MonadReader Settings m +installUnpackedGHC :: ( MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -214,7 +214,7 @@ installUnpackedGHC path inst ver (PlatformRequest {..}) = do installGHCBin :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -246,7 +246,7 @@ installGHCBin bDls ver pfreq = do -- argument instead of looking it up from 'GHCupDownloads'. installCabalBindist :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -273,7 +273,7 @@ installCabalBindist :: ( MonadMask m installCabalBindist dlinfo ver (PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ @@ -328,7 +328,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do -- the latest installed version. installCabalBin :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -361,7 +361,7 @@ installCabalBin bDls ver pfreq = do -- argument instead of looking it up from 'GHCupDownloads'. installHLSBindist :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -388,7 +388,7 @@ installHLSBindist :: ( MonadMask m installHLSBindist dlinfo ver (PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask whenM (lift (hlsInstalled ver)) $ (throwE $ AlreadyInstalled HLS ver) @@ -452,7 +452,7 @@ installHLSBindist dlinfo ver (PlatformRequest {..}) = do -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -498,7 +498,7 @@ installHLSBin bDls ver pfreq = do -- -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ -- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader Settings m +setGHC :: ( MonadReader AppState m , MonadLogger m , MonadThrow m , MonadFail m @@ -515,7 +515,7 @@ setGHC ver sghc = do whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) -- symlink destination - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask liftIO $ createDirRecursive' binDir -- first delete the old symlinks (this fixes compatibility issues @@ -556,12 +556,12 @@ setGHC ver sghc = do where - symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m) + symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m) => Path Abs -> ByteString -> m () symlinkShareDir ghcdir verBS = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask let destdir = baseDir case sghc of SetGHCOnly -> do @@ -579,7 +579,7 @@ setGHC ver sghc = do -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Version -> Excepts '[NotInstalled] m () setCabal ver = do @@ -587,7 +587,7 @@ setCabal ver = do targetFile <- parseRel ("cabal-" <> verBS) -- symlink destination - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask liftIO $ createDirRecursive' binDir whenM (liftIO $ fmap not $ doesFileExist (binDir targetFile)) @@ -613,7 +613,7 @@ setCabal ver = do -- | Set the haskell-language-server symlinks. setHLS :: ( MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadThrow m , MonadFail m @@ -622,7 +622,7 @@ setHLS :: ( MonadCatch m => Version -> Excepts '[NotInstalled] m () setHLS ver = do - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask liftIO $ createDirRecursive' binDir -- Delete old symlinks, since these might have different ghc versions than the @@ -703,7 +703,7 @@ listVersions :: ( MonadCatch m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader Settings m + , MonadReader AppState m ) => GHCupDownloads -> Maybe Tool @@ -736,7 +736,7 @@ listVersions av lt criteria pfreq = do pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers) where - strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) + strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayGHCs avTools = do @@ -778,7 +778,7 @@ listVersions av lt criteria pfreq = do [i|Could not parse version of stray directory #{toFilePath e}|] pure Nothing - strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayCabals avTools = do @@ -806,7 +806,7 @@ listVersions av lt criteria pfreq = do [i|Could not parse version of stray directory #{toFilePath e}|] pure Nothing - strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayHLS avTools = do @@ -835,7 +835,7 @@ listVersions av lt criteria pfreq = do pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult + toListResult :: (MonadReader AppState m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult toListResult t (v, tags) = case t of GHC -> do let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av @@ -904,7 +904,7 @@ listVersions av lt criteria pfreq = do -- This may leave GHCup without a "set" version. -- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- older version). -rmGHCVer :: ( MonadReader Settings m +rmGHCVer :: ( MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -942,7 +942,7 @@ rmGHCVer ver = do forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask liftIO $ hideError doesNotExistErrorType @@ -952,7 +952,7 @@ rmGHCVer ver = do -- | Delete a cabal version. Will try to fix the @cabal@ symlink -- after removal (e.g. setting it to an older version). -rmCabalVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) +rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) => Version -> Excepts '[NotInstalled] m () rmCabalVer ver = do @@ -960,7 +960,7 @@ rmCabalVer ver = do cSet <- lift $ cabalSet - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir cabalFile) @@ -975,7 +975,7 @@ rmCabalVer ver = do -- | Delete a hls version. Will try to fix the hls symlinks -- after removal (e.g. setting it to an older version). -rmHLSVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) +rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) => Version -> Excepts '[NotInstalled] m () rmHLSVer ver = do @@ -983,7 +983,7 @@ rmHLSVer ver = do isHlsSet <- lift $ hlsSet - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask bins <- lift $ hlsAllBinaries ver forM_ bins $ \f -> liftIO $ deleteFile (binDir f) @@ -1008,13 +1008,13 @@ rmHLSVer ver = do ------------------ -getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m) +getDebugInfo :: (MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m) => Excepts '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] m DebugInfo getDebugInfo = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask let diBaseDir = baseDir let diBinDir = binDir diGHCDir <- lift ghcupGHCBaseDir @@ -1034,7 +1034,7 @@ getDebugInfo = do -- | Compile a GHC from source. This behaves wrt symlinks and installation -- the same as 'installGHCBin'. compileGHC :: ( MonadMask m - , MonadReader Settings m + , MonadReader AppState m , MonadThrow m , MonadResource m , MonadLogger m @@ -1135,7 +1135,7 @@ BUILD_SPHINX_PDF = NO HADDOCK_DOCS = NO Stage1Only = YES|] - compileBindist :: ( MonadReader Settings m + compileBindist :: ( MonadReader AppState m , MonadThrow m , MonadCatch m , MonadLogger m @@ -1153,7 +1153,7 @@ Stage1Only = YES|] lift $ $(logInfo) [i|configuring build|] liftE $ checkBuildConfig - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir @@ -1270,7 +1270,7 @@ Stage1Only = YES|] -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- if no path is provided. upgradeGHCup :: ( MonadMask m - , MonadReader Settings m + , MonadReader AppState m , MonadCatch m , MonadLogger m , MonadThrow m @@ -1292,7 +1292,7 @@ upgradeGHCup :: ( MonadMask m m Version upgradeGHCup dls mtarget force pfreq = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ getLatest dls GHCup when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate @@ -1317,7 +1317,7 @@ upgradeGHCup dls mtarget force pfreq = do -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. -postGHCInstall :: ( MonadReader Settings m +postGHCInstall :: ( MonadReader AppState m , MonadLogger m , MonadThrow m , MonadFail m diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index af8aa16..c07f3ff 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -83,9 +83,9 @@ import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as L +import qualified Data.Map.Strict as M #if defined(INTERNAL_DOWNLOADER) import qualified Data.CaseInsensitive as CI -import qualified Data.Map.Strict as M import qualified Data.Text as T #endif import qualified Data.Text.Encoding as E @@ -104,8 +104,8 @@ import qualified System.Posix.RawFilePath.Directory ------------------ --- | Like 'getDownloads', but tries to fall back to --- cached ~/.ghcup/cache/ghcup-.yaml + +-- | Downloads the download information! But only if we need to ;P getDownloadsF :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo @@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader Settings m + , MonadReader AppState m ) => URLSource -> Excepts @@ -123,17 +123,24 @@ getDownloadsF :: ( FromJSONKey Tool GHCupInfo getDownloadsF urlSource = do case urlSource of - GHCupURL -> - liftE - $ handleIO (\_ -> readFromCache) - $ catchE @_ @'[JSONError , FileDoesNotExistError] - (\(DownloadFailed _) -> readFromCache) - $ getDownloads urlSource - (OwnSource _) -> liftE $ getDownloads urlSource - (OwnSpec _) -> liftE $ getDownloads urlSource + GHCupURL -> liftE getBase + (OwnSource url) -> do + bs <- reThrowAll DownloadFailed $ downloadBS url + lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) + (OwnSpec av) -> pure av + (AddSource (Left ext)) -> do + base <- liftE getBase + pure (mergeGhcupInfo base ext) + (AddSource (Right uri)) -> do + base <- liftE getBase + 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 - Settings {dirs = Dirs {..}} <- lift ask + 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 @@ -145,32 +152,25 @@ getDownloadsF urlSource = do $ 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)) --- | Downloads the download information! But only if we need to ;P -getDownloads :: ( FromJSONKey Tool - , FromJSONKey Version - , FromJSON VersionInfo - , MonadIO m - , MonadCatch m - , MonadLogger m - , MonadThrow m - , MonadFail m - , MonadReader Settings m - ) - => URLSource - -> Excepts '[JSONError , DownloadFailed] m GHCupInfo -getDownloads urlSource = do - lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] - case urlSource of - GHCupURL -> do - bs <- reThrowAll DownloadFailed $ smartDl ghcupURL - lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) - (OwnSource url) -> do - bs <- reThrowAll DownloadFailed $ downloadBS url - lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) - (OwnSpec av) -> pure $ av + mergeGhcupInfo :: GHCupInfo -- ^ base to merge with + -> GHCupInfo -- ^ extension overwriting the base + -> GHCupInfo + mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) = + let new = M.mapWithKey (\k a -> case M.lookup k ext of + Just a' -> M.union a' a + Nothing -> a + ) base + in GHCupInfo tr new - 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. @@ -185,7 +185,7 @@ getDownloads urlSource = do , MonadIO m1 , MonadFail m1 , MonadLogger m1 - , MonadReader Settings m1 + , MonadReader AppState m1 ) => URI -> Excepts @@ -200,7 +200,7 @@ getDownloads urlSource = do m1 L.ByteString smartDl uri' = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask let path = view pathL' uri' json_file <- (cacheDir ) <$> urlBaseName path e <- liftIO $ doesFileExist json_file @@ -311,7 +311,7 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe -- -- The file must not exist. download :: ( MonadMask m - , MonadReader Settings m + , MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -383,7 +383,7 @@ downloadCached :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader Settings m + , MonadReader AppState m ) => DownloadInfo -> Maybe (Path Rel) -- ^ optional filename @@ -392,7 +392,7 @@ downloadCached dli mfn = do cache <- lift getCache case cache of True -> do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn let cachfile = cacheDir fn fileExists <- liftIO $ doesFileExist cachfile @@ -416,7 +416,7 @@ downloadCached dli mfn = do -- | This is used for downloading the JSON. -downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m) +downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m) => URI -> Excepts '[ FileDoesNotExistError @@ -473,12 +473,12 @@ downloadBS uri' #endif -checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m) +checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m) => DownloadInfo -> Path Abs -> Excepts '[DigestError] m () checkDigest dli file = do - verify <- lift ask <&> (not . noVerify) + verify <- lift ask <&> (not . noVerify . settings) when verify $ do p' <- toFilePath <$> basename file lift $ $(logInfo) [i|verifying digest of: #{p'}|] diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 9857cf3..4387f39 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -21,6 +21,7 @@ import URI.ByteString import qualified Data.Text as T import qualified GHC.Generics as GHC +import qualified Graphics.Vty as Vty @@ -190,27 +191,82 @@ data TarDir = RealDir (Path Rel) data URLSource = GHCupURL | OwnSource URI | OwnSpec GHCupInfo + | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL deriving (GHC.Generic, Show) +data UserSettings = UserSettings + { uCache :: Maybe Bool + , uNoVerify :: Maybe Bool + , uVerbose :: Maybe Bool + , uKeepDirs :: Maybe KeepDirs + , uDownloader :: Maybe Downloader + , uKeyBindings :: Maybe UserKeyBindings + , uUrlSource :: Maybe URLSource + } + deriving (Show, GHC.Generic) + +defaultUserSettings :: UserSettings +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data UserKeyBindings = UserKeyBindings + { kUp :: Maybe Vty.Key + , kDown :: Maybe Vty.Key + , kQuit :: Maybe Vty.Key + , kInstall :: Maybe Vty.Key + , kUninstall :: Maybe Vty.Key + , kSet :: Maybe Vty.Key + , kChangelog :: Maybe Vty.Key + , kShowAll :: Maybe Vty.Key + } + deriving (Show, GHC.Generic) + +data KeyBindings = KeyBindings + { bUp :: Vty.Key + , bDown :: Vty.Key + , bQuit :: Vty.Key + , bInstall :: Vty.Key + , bUninstall :: Vty.Key + , bSet :: Vty.Key + , bChangelog :: Vty.Key + , bShowAll :: Vty.Key + } + deriving (Show, GHC.Generic) + +defaultKeyBindings :: KeyBindings +defaultKeyBindings = KeyBindings + { bUp = Vty.KUp + , bDown = Vty.KDown + , bQuit = Vty.KChar 'q' + , bInstall = Vty.KChar 'i' + , bUninstall = Vty.KChar 'u' + , bSet = Vty.KChar 's' + , bChangelog = Vty.KChar 'c' + , bShowAll = Vty.KChar 'a' + } + +data AppState = AppState + { settings :: Settings + , dirs :: Dirs + , keyBindings :: KeyBindings + } deriving (Show) + data Settings = Settings - { -- set by user - cache :: Bool + { cache :: Bool , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader , verbose :: Bool - - -- set on app start - , dirs :: Dirs + , urlSource :: URLSource } - deriving Show + deriving (Show, GHC.Generic) data Dirs = Dirs { baseDir :: Path Abs , binDir :: Path Abs , cacheDir :: Path Abs , logsDir :: Path Abs + , confDir :: Path Abs } deriving Show diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8904b91..e68a608 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -33,14 +33,17 @@ import Data.Versions import Data.Word8 import HPath import URI.ByteString +import Text.Casing import qualified Data.ByteString as BS import qualified Data.Text as T +import qualified Graphics.Vty as Vty deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool @@ -50,6 +53,12 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader +deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource +deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings +deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings +deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key instance ToJSON Tag where toJSON Latest = String "Latest" diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index db0c148..95e65d2 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -50,6 +50,7 @@ import Data.ByteString ( ByteString ) import Data.Either import Data.Foldable import Data.List +import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.List.Split import Data.Maybe import Data.String.Interpolate @@ -99,21 +100,21 @@ import qualified Text.Megaparsec as MP -- | The symlink destination of a ghc tool. -ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m) +ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m) => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc. -> GHCTargetVersion -> m ByteString ghcLinkDestination tool ver = do - Settings {dirs = Dirs {..}} <- ask + AppState { dirs = Dirs {..} } <- ask t <- parseRel tool ghcd <- ghcupGHCDir ver pure (relativeSymlink binDir (ghcd [rel|bin|] t)) -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m () +rmMinorSymlinks :: (MonadReader AppState m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m () rmMinorSymlinks GHCTargetVersion {..} = do - Settings {dirs = Dirs {..}} <- ask + AppState { dirs = Dirs {..} } <- ask files <- liftIO $ findFiles' binDir @@ -130,11 +131,11 @@ rmMinorSymlinks GHCTargetVersion {..} = do -- | Removes the set ghc version for the given target, if any. -rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +rmPlain :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Maybe Text -- ^ target -> Excepts '[NotInstalled] m () rmPlain target = do - Settings {dirs = Dirs {..}} <- lift ask + AppState { dirs = Dirs {..} } <- lift ask mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do files <- liftE $ ghcToolFiles tv @@ -149,11 +150,11 @@ rmPlain target = do -- | Remove the major GHC symlink, e.g. ghc-8.6. -rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) +rmMajorSymlinks :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) => GHCTargetVersion -> m () rmMajorSymlinks GHCTargetVersion {..} = do - Settings {dirs = Dirs {..}} <- ask + AppState { dirs = Dirs {..} } <- ask (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi @@ -179,26 +180,26 @@ rmMajorSymlinks GHCTargetVersion {..} = do -- | Whethe the given GHC versin is installed. -ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesDirectoryExist ghcdir -- | Whether the given GHC version is installed from source. -ghcSrcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. -ghcSet :: (MonadReader Settings m, MonadThrow m, MonadIO m) +ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m) => Maybe Text -- ^ the target of the GHC version, if any -- (e.g. armv7-unknown-linux-gnueabihf) -> m (Maybe GHCTargetVersion) ghcSet mtarget = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget) let ghcBin = binDir ghc @@ -231,7 +232,7 @@ ghcLinkVersion bs = do -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. -getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion] +getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir @@ -241,10 +242,10 @@ getInstalledGHCs = do -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m) +getInstalledCabals :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Either (Path Rel) Version] getInstalledCabals = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) @@ -257,16 +258,16 @@ getInstalledCabals = do -- | Whether the given cabal version is installed. -cabalInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool +cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool cabalInstalled ver = do vers <- fmap rights $ getInstalledCabals pure $ elem ver $ vers -- Return the currently set cabal version, if any. -cabalSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +cabalSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask let cabalbin = binDir [rel|cabal|] b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin if @@ -303,10 +304,10 @@ cabalSet = do -- | Get all installed hls, by matching on -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -getInstalledHLSs :: (MonadReader Settings m, MonadIO m, MonadCatch m) +getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Either (Path Rel) Version] getInstalledHLSs = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -326,7 +327,7 @@ getInstalledHLSs = do -- | Whether the given HLS version is installed. -hlsInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool +hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool hlsInstalled ver = do vers <- fmap rights $ getInstalledHLSs pure $ elem ver $ vers @@ -334,9 +335,9 @@ hlsInstalled ver = do -- Return the currently set hls version, if any. -hlsSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) hlsSet = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask let hlsBin = binDir [rel|haskell-language-server-wrapper|] liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do @@ -357,7 +358,7 @@ hlsSet = do -- | Return the GHC versions the currently selected HLS supports. -hlsGHCVersions :: ( MonadReader Settings m +hlsGHCVersions :: ( MonadReader AppState m , MonadIO m , MonadThrow m , MonadCatch m @@ -383,11 +384,11 @@ hlsGHCVersions = do -- | Get all server binaries for an hls version, if any. -hlsServerBinaries :: (MonadReader Settings m, MonadIO m) +hlsServerBinaries :: (MonadReader AppState m, MonadIO m) => Version -> m [Path Rel] hlsServerBinaries ver = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts @@ -399,11 +400,11 @@ hlsServerBinaries ver = do -- | Get the wrapper binary for an hls version, if any. -hlsWrapperBinary :: (MonadReader Settings m, MonadThrow m, MonadIO m) +hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m) => Version -> m (Maybe (Path Rel)) hlsWrapperBinary ver = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts @@ -420,7 +421,7 @@ hlsWrapperBinary ver = do -- | Get all binaries for an hls version, if any. -hlsAllBinaries :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Version -> m [Path Rel] +hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel] hlsAllBinaries ver = do hls <- hlsServerBinaries ver wrapper <- hlsWrapperBinary ver @@ -428,9 +429,9 @@ hlsAllBinaries ver = do -- | Get the active symlinks for hls. -hlsSymlinks :: (MonadReader Settings m, MonadIO m, MonadCatch m) => m [Path Rel] +hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel] hlsSymlinks = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -455,7 +456,7 @@ hlsSymlinks = do -- | Extract (major, minor) from any version. getMajorMinorV :: MonadThrow m => Version -> m (Int, Int) getMajorMinorV Version {..} = case _vChunks of - ([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y) + ((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y) _ -> throwM $ ParseError "Could not parse X.Y from version" @@ -467,7 +468,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of -- | Get the latest installed full GHC version that satisfies X.Y. -- This reads `ghcupGHCBaseDir`. -getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m) +getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Int -- ^ major version component -> Int -- ^ minor version component -> Maybe Text -- ^ the target triple @@ -603,16 +604,16 @@ getLatestBaseVersion av pvpVer = ----------------------- - --[ Settings Getter ]-- + --[ AppState Getter ]-- ----------------------- -getCache :: MonadReader Settings m => m Bool -getCache = ask <&> cache +getCache :: MonadReader AppState m => m Bool +getCache = ask <&> cache . settings -getDownloader :: MonadReader Settings m => m Downloader -getDownloader = ask <&> downloader +getDownloader :: MonadReader AppState m => m Downloader +getDownloader = ask <&> downloader . settings @@ -633,7 +634,7 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False -- Returns unversioned relative files, e.g.: -- -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m) +ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel] ghcToolFiles ver = do @@ -686,7 +687,7 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|] -- | Calls gmake if it exists in PATH, otherwise make. -make :: (MonadThrow m, MonadIO m, MonadReader Settings m) +make :: (MonadThrow m, MonadIO m, MonadReader AppState m) => [ByteString] -> Maybe (Path Abs) -> m (Either ProcessError ()) @@ -739,13 +740,13 @@ getChangeLog dls tool (Right tag) = -- -- 1. the build directory, depending on the KeepDirs setting -- 2. the install destination, depending on whether the build failed -runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m) +runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m) => Path Abs -- ^ build directory (cleaned up depending on Settings) -> Maybe (Path Abs) -- ^ dir to *always* clean up on exception -> Excepts e m a -> Excepts '[BuildFailed] m a runBuildAction bdir instdir action = do - Settings {..} <- lift ask + AppState { settings = Settings {..} } <- lift ask let exAction = do forM_ instdir $ \dir -> liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 2704e42..0c2df15 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} @@ -14,16 +15,18 @@ Portability : POSIX -} module GHCup.Utils.Dirs ( getDirs + , ghcupConfigFile , ghcupGHCBaseDir , ghcupGHCDir - , parseGHCupGHCDir , mkGhcupTmpDir - , withGHCupTmpDir + , parseGHCupGHCDir , relativeSymlink + , withGHCupTmpDir ) where +import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Utils.MegaParsec @@ -34,8 +37,11 @@ import Control.Exception.Safe import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Resource +import Data.Bifunctor import Data.ByteString ( ByteString ) import Data.Maybe +import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) +import Haskus.Utils.Variant.Excepts import HPath import HPath.IO import Optics @@ -49,8 +55,10 @@ import System.Posix.Env.ByteString ( getEnv import System.Posix.FilePath hiding ( () ) import System.Posix.Temp.ByteString ( mkdtemp ) +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Text.Encoding as E +import qualified Data.Yaml as Y import qualified System.Posix.FilePath as FP import qualified System.Posix.User as PU import qualified Text.Megaparsec as MP @@ -84,6 +92,28 @@ ghcupBaseDir = do pure (bdir [rel|.ghcup|]) +-- | ~/.ghcup by default +-- +-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), +-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec. +ghcupConfigDir :: IO (Path Abs) +ghcupConfigDir = do + xdg <- useXDG + if xdg + then do + bdir <- getEnv "XDG_CONFIG_HOME" >>= \case + Just r -> parseAbs r + Nothing -> do + home <- liftIO getHomeDirectory + pure (home [rel|.config|]) + pure (bdir [rel|ghcup|]) + else do + bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case + Just r -> parseAbs r + Nothing -> liftIO getHomeDirectory + pure (bdir [rel|.ghcup|]) + + -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin' -- (which, sadly is not strictly xdg spec). @@ -142,27 +172,44 @@ getDirs = do binDir <- ghcupBinDir cacheDir <- ghcupCacheDir logsDir <- ghcupLogsDir + confDir <- ghcupConfigDir pure Dirs { .. } + ------------------- + --[ GHCup files ]-- + ------------------- + + +ghcupConfigFile :: (MonadIO m) + => Excepts '[JSONError] m UserSettings +ghcupConfigFile = do + confDir <- liftIO $ ghcupConfigDir + let file = confDir [rel|config.yaml|] + bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file + case bs of + Nothing -> pure defaultUserSettings + Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs' + + ------------------------- --[ GHCup directories ]-- ------------------------- -- | ~/.ghcup/ghc by default. -ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs) +ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs) ghcupGHCBaseDir = do - Settings {..} <- ask - pure (baseDir dirs [rel|ghc|]) + AppState { dirs = Dirs {..} } <- ask + pure (baseDir [rel|ghc|]) -- | Gets '~/.ghcup/ghc/'. -- The dir may be of the form -- * armv7-unknown-linux-gnueabihf-8.8.3 -- * 8.8.4 -ghcupGHCDir :: (MonadReader Settings m, MonadThrow m) +ghcupGHCDir :: (MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m (Path Abs) ghcupGHCDir ver = do diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 928390b..e5301a0 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -117,7 +117,7 @@ executeOut path args chdir = captureOutStreams $ do SPPB.executeFile (toFilePath path) True args Nothing -execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) +execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) => ByteString -- ^ thing to execute -> Bool -- ^ whether to search PATH for the thing -> [ByteString] -- ^ args for the thing @@ -126,7 +126,7 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) -> Maybe [(ByteString, ByteString)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe spath args lfile chdir env = do - Settings {dirs = Dirs {..}, ..} <- ask + AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask logfile <- (logsDir ) <$> parseRel (toFilePath lfile <> ".log") liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 5dece20..53043b4 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -65,9 +65,9 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger rawOutter outr -initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs) +initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => Path Rel -> m (Path Abs) initGHCupFileLogging context = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask let logfile = logsDir context liftIO $ do createDirRecursive' logsDir diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Utils/MegaParsec.hs index ac379fe..a069f55 100644 --- a/lib/GHCup/Utils/MegaParsec.hs +++ b/lib/GHCup/Utils/MegaParsec.hs @@ -25,6 +25,7 @@ import Data.Text ( Text ) import Data.Versions import Data.Void +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Text.Megaparsec as MP @@ -90,6 +91,8 @@ ghcTargetVerP = (Digits _) -> True (Str _) -> False ) + . fmap NE.toList + . NE.toList $ (_vChunks v) if startsWithDigists && not (isJust (_vEpoch v)) then pure $ prettyVer v diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Utils/Version/QQ.hs index 73912cc..ee63167 100644 --- a/lib/GHCup/Utils/Version/QQ.hs +++ b/lib/GHCup/Utils/Version/QQ.hs @@ -42,6 +42,8 @@ deriving instance Data SemVer deriving instance Lift SemVer deriving instance Data Mess deriving instance Lift Mess +deriving instance Data MChunk +deriving instance Lift MChunk deriving instance Data PVP deriving instance Lift PVP deriving instance Lift VSep diff --git a/stack.yaml b/stack.yaml index a1d27cc..0719e18 100644 --- a/stack.yaml +++ b/stack.yaml @@ -47,6 +47,7 @@ extra-deps: - streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138 - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248 - tar-bytestring-0.6.3.2@sha256:88f29bed56b688c543a4cb3986402d64b360f76b3fd9b88ac618b8344f8da712,5715 + - versions-4.0.1@sha256:0f644c1587d38f0eb3c3fe364bf1822424db43cbd4d618d0e21473b062c45239,1936 - vty-5.30@sha256:4af3938d7b9e6096e222bf52d0ea5d39873bc6fe19febd34106906306af13730,20857 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 @@ -59,6 +60,7 @@ flags: ghcup: tui: true + internal-downloader: true system-ghc: true compiler: ghc-8.8.4