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

Merge branch 'settings' into master

Browse Source
This commit is contained in:
Julian Ospald 2020-10-26 18:25:20 +01:00
commit 3e841b3c68
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
20 changed files with 602 additions and 302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@ -7,6 +7,7 @@
- reverse list order so latest is on top - reverse list order so latest is on top
- expand the blues selected bar - expand the blues selected bar
- show new latest versions in bright white - show new latest versions in bright white
* allow configuration file and settings TUI hotkeys wrt #41
## 0.1.11 -- 2020-09-23 ## 0.1.11 -- 2020-09-23

8
README.md
View File

@ -13,6 +13,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Manual install](#manual-install) * [Manual install](#manual-install)
* [Vim integration](#vim-integration) * [Vim integration](#vim-integration)
* [Usage](#usage) * [Usage](#usage)
* [Configuration](#configuration)
* [Manpages](#manpages) * [Manpages](#manpages)
* [Shell-completion](#shell-completion) * [Shell-completion](#shell-completion)
* [Cross support](#cross-support) * [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 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. 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 ### 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. 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.

2
app/ghcup-gen/Validate.hs
View File

@ -193,7 +193,7 @@ validateTarballs dls = do
where where
downloadAll dli = do downloadAll dli = do
dirs <- liftIO getDirs 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 let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ()) , rawOutter = (\_ -> pure ())

192
app/ghcup/BrickMain.hs
View File

@ -36,7 +36,6 @@ import Data.Bool
import Data.Functor import Data.Functor
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Char
import Data.IORef import Data.IORef
import Data.String.Interpolate import Data.String.Interpolate
import Data.Vector ( Vector import Data.Vector ( Vector
@ -55,59 +54,70 @@ import qualified Data.Vector as V
data AppData = AppData data BrickData = BrickData
{ lr :: [ListResult] { lr :: [ListResult]
, dls :: GHCupDownloads , dls :: GHCupDownloads
, pfreq :: PlatformRequest , pfreq :: PlatformRequest
} }
deriving Show deriving Show
data AppSettings = AppSettings data BrickSettings = BrickSettings
{ showAll :: Bool { showAll :: Bool
} }
deriving Show deriving Show
data AppInternalState = AppInternalState data BrickInternalState = BrickInternalState
{ clr :: Vector ListResult { clr :: Vector ListResult
, ix :: Int , ix :: Int
} }
deriving Show deriving Show
data AppState = AppState data BrickState = BrickState
{ appData :: AppData { appData :: BrickData
, appSettings :: AppSettings , appSettings :: BrickSettings
, appState :: AppInternalState , appState :: BrickInternalState
, appKeys :: KeyBindings
} }
deriving Show deriving Show
keyHandlers :: [ ( Char keyHandlers :: KeyBindings
, AppSettings -> String -> [ ( Vty.Key
, AppState -> EventM n (Next AppState) , BrickSettings -> String
, BrickState -> EventM n (Next BrickState)
) )
] ]
keyHandlers = keyHandlers KeyBindings {..} =
[ ('q', const "Quit" , halt) [ (bQuit, const "Quit" , halt)
, ('i', const "Install" , withIOAction install') , (bInstall, const "Install" , withIOAction install')
, ('u', const "Uninstall", withIOAction del') , (bUninstall, const "Uninstall", withIOAction del')
, ('s', const "Set" , withIOAction set') , (bSet, const "Set" , withIOAction set')
, ('c', const "ChangeLog", withIOAction changelog') , (bChangelog, const "ChangeLog", withIOAction changelog')
, ( 'a' , ( bShowAll
, (\AppSettings {..} -> , (\BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions" if showAll then "Hide old versions" else "Show all versions"
) )
, hideShowHandler , hideShowHandler
) )
, (bUp, const "Up", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Up), .. }))
, (bDown, const "Down", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Down), .. }))
] ]
where where
hideShowHandler (AppState {..}) = hideShowHandler (BrickState {..}) =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings } let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
newInternalState = constructList appData newAppSettings (Just appState) newInternalState = constructList appData newAppSettings (Just appState)
in continue (AppState appData newAppSettings newInternalState) in continue (BrickState appData newAppSettings newInternalState appKeys)
ui :: AppState -> Widget String showKey :: Vty.Key -> String
ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} 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 = ( padBottom Max
$ ( withBorderStyle unicode $ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup") $ borderWithLabel (str "GHCup")
@ -122,8 +132,7 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
. txtWrap . txtWrap
. T.pack . T.pack
. foldr1 (\x y -> x <> " " <> y) . foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"]) $ (fmap (\(key, s, _) -> (showKey key <> ":" <> s as)) $ keyHandlers appKeys)
$ (fmap (\(c, s, _) -> (c : ':' : s as)) keyHandlers)
header = header =
(minHSize 2 $ emptyWidget) (minHSize 2 $ emptyWidget)
<+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool") <+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool")
@ -196,9 +205,9 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
-- available height. -- available height.
drawListElements :: (Int -> Bool -> ListResult -> Widget String) drawListElements :: (Int -> Bool -> ListResult -> Widget String)
-> Bool -> Bool
-> AppInternalState -> BrickInternalState
-> Widget String -> Widget String
drawListElements drawElem foc is@(AppInternalState clr _) = drawListElements drawElem foc is@(BrickInternalState clr _) =
Widget Greedy Greedy $ Widget Greedy Greedy $
let let
es = clr es = clr
@ -228,7 +237,7 @@ minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String app :: App BrickState e String
app = App { appDraw = \st -> [ui st] app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler , appHandleEvent = eventHandler
, appStartEvent = return , appStartEvent = return
@ -261,34 +270,40 @@ dimAttributes = attrMap
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) , ("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 :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st eventHandler st@(BrickState {..}) ev = do
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st AppState { keyBindings = kb } <- liftIO $ readIORef settings'
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = case ev of
continue (AppState { appState = (moveCursor appState Up), .. }) (MouseDown _ Vty.BScrollUp _ _) ->
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = continue (BrickState { appState = moveCursor 1 appState Up, .. })
continue (AppState { appState = (moveCursor appState Down), .. }) (MouseDown _ Vty.BScrollDown _ _) ->
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = continue (BrickState { appState = moveCursor 1 appState Down, .. })
case find (\(c', _, _) -> c' == c) keyHandlers of (VtyEvent (Vty.EvResize _ _)) -> continue st
Nothing -> continue as (VtyEvent (Vty.EvKey Vty.KUp _)) ->
Just (_, _, handler) -> handler as continue (BrickState { appState = (moveCursor 1 appState Up), .. })
eventHandler st _ = continue st (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 :: Int -> BrickInternalState -> Direction -> BrickInternalState
moveCursor ais@(AppInternalState {..}) direction = moveCursor steps ais@(BrickInternalState {..}) direction =
let newIx = if direction == Down then ix + 1 else ix - 1 let newIx = if direction == Down then ix + steps else ix - steps
in case clr !? newIx of in case clr !? newIx of
Just _ -> AppInternalState { ix = newIx, .. } Just _ -> BrickInternalState { ix = newIx, .. }
Nothing -> ais Nothing -> ais
-- | Suspend the current UI and run an IO action in terminal. If the -- | 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. -- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a)) withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a))
-> AppState -> BrickState
-> EventM n (Next AppState) -> EventM n (Next BrickState)
withIOAction action as = case listSelectedElement' (appState as) of withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> continue as Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do 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. -- | Update app data and list internal state based on new evidence.
-- This synchronises @AppInternalState@ with @AppData@ -- This synchronises @BrickInternalState@ with @BrickData@
-- and @AppSettings@. -- and @BrickSettings@.
updateList :: AppData -> AppState -> AppState updateList :: BrickData -> BrickState -> BrickState
updateList appD (AppState {..}) = updateList appD (BrickState {..}) =
let newInternalState = constructList appD appSettings (Just appState) let newInternalState = constructList appD appSettings (Just appState)
in AppState { appState = newInternalState in BrickState { appState = newInternalState
, appData = appD , appData = appD
, appSettings = appSettings , appSettings = appSettings
} , appKeys = appKeys
}
constructList :: AppData constructList :: BrickData
-> AppSettings -> BrickSettings
-> Maybe AppInternalState -> Maybe BrickInternalState
-> AppInternalState -> BrickInternalState
constructList appD appSettings mapp = constructList appD appSettings mapp =
replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp
listSelectedElement' :: AppInternalState -> Maybe (Int, ListResult) listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' (AppInternalState {..}) = fmap (ix, ) $ clr !? ix listSelectedElement' (BrickInternalState {..}) = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int selectLatest :: Vector ListResult -> Int
@ -338,8 +354,8 @@ selectLatest v =
-- When passed an existing @appState@, tries to keep the selected element. -- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool) replaceLR :: (ListResult -> Bool)
-> [ListResult] -> [ListResult]
-> Maybe AppInternalState -> Maybe BrickInternalState
-> AppInternalState -> BrickInternalState
replaceLR filterF lr s = replaceLR filterF lr s =
let oldElem = s >>= listSelectedElement' let oldElem = s >>= listSelectedElement'
newVec = V.fromList . filter filterF $ lr newVec = V.fromList . filter filterF $ lr
@ -347,7 +363,7 @@ replaceLR filterF lr s =
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
Just ix -> ix Just ix -> ix
Nothing -> selectLatest newVec Nothing -> selectLatest newVec
in AppInternalState newVec newSelected in BrickInternalState newVec newSelected
where where
toolEqual e1 e2 = toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross 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)) | otherwise = not (elem Old (lTag e))
install' :: AppState -> (Int, ListResult) -> IO (Either String ()) install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
install' AppState { appData = AppData {..} } (_, ListResult {..}) = do install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
let runLogger = myLoggerT l let runLogger = myLoggerT l
@ -406,7 +422,7 @@ install' AppState { appData = AppData {..} } (_, ListResult {..}) = do
Also check the logs in ~/.ghcup/logs|] Also check the logs in ~/.ghcup/logs|]
set' :: AppState -> (Int, ListResult) -> IO (Either String ()) set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do set' _ (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -429,7 +445,7 @@ set' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left [i|#{e}|]
del' :: AppState -> (Int, ListResult) -> IO (Either String ()) del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do del' _ (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -449,8 +465,8 @@ del' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left [i|#{e}|]
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ()) changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState { appData = AppData {..} } (_, ListResult {..}) = do changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|] [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
@ -469,17 +485,21 @@ uri' :: IORef (Maybe URI)
uri' = unsafePerformIO (newIORef Nothing) uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings settings' :: IORef AppState
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do settings' = unsafePerformIO $ do
dirs <- getDirs dirs <- getDirs
newIORef Settings { cache = True newIORef $ AppState (Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
, downloader = Curl , downloader = Curl
, verbose = False , verbose = False
, .. , urlSource = GHCupURL
} , ..
})
dirs
defaultKeyBindings
logger' :: IORef LoggerConfig logger' :: IORef LoggerConfig
@ -492,7 +512,7 @@ logger' = unsafePerformIO
) )
brickMain :: Settings brickMain :: AppState
-> Maybe URI -> Maybe URI
-> LoggerConfig -> LoggerConfig
-> GHCupDownloads -> GHCupDownloads
@ -510,9 +530,11 @@ brickMain s muri l av pfreq' = do
Right ad -> Right ad ->
defaultMain defaultMain
app app
(AppState ad (BrickState ad
defaultAppSettings defaultAppSettings
(constructList ad defaultAppSettings Nothing) (constructList ad defaultAppSettings Nothing)
(keyBindings s)
) )
$> () $> ()
Left e -> do Left e -> do
@ -520,8 +542,8 @@ brickMain s muri l av pfreq' = do
exitWith $ ExitFailure 2 exitWith $ ExitFailure 2
defaultAppSettings :: AppSettings defaultAppSettings :: BrickSettings
defaultAppSettings = AppSettings { showAll = False } defaultAppSettings = BrickSettings { showAll = False }
getDownloads' :: IO (Either String GHCupDownloads) getDownloads' :: IO (Either String GHCupDownloads)
@ -546,7 +568,7 @@ getDownloads' = do
getAppData :: Maybe GHCupDownloads getAppData :: Maybe GHCupDownloads
-> PlatformRequest -> PlatformRequest
-> IO (Either String AppData) -> IO (Either String BrickData)
getAppData mg pfreq' = do getAppData mg pfreq' = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -558,6 +580,6 @@ getAppData mg pfreq' = do
case r of case r of
Right dls -> do Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq' 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}|] Left e -> pure $ Left [i|#{e}|]

217
app/ghcup/Main.hs
View File

@ -81,12 +81,12 @@ import qualified Text.Megaparsec.Char as MPC
data Options = Options data Options = Options
{ {
-- global options -- global options
optVerbose :: Bool optVerbose :: Maybe Bool
, optCache :: Bool , optCache :: Maybe Bool
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URI
, optNoVerify :: Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: KeepDirs , optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Downloader , optsDownloader :: Maybe Downloader
-- commands -- commands
, optCommand :: Command , optCommand :: Command
} }
@ -122,6 +122,7 @@ data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest , instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI , instBindist :: Maybe URI
, instSet :: Bool
} }
data SetCommand = SetGHC SetOptions data SetCommand = SetGHC SetOptions
@ -158,6 +159,7 @@ data GHCCompileOptions = GHCCompileOptions
, patchDir :: Maybe (Path Abs) , patchDir :: Maybe (Path Abs)
, crossTarget :: Maybe Text , crossTarget :: Maybe Text
, addConfArgs :: [Text] , addConfArgs :: [Text]
, setCompile :: Bool
} }
data CabalCompileOptions = CabalCompileOptions 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 :: Parser Options
opts = opts =
Options Options
<$> switch (short 'v' <> long "verbose" <> help "Enable verbosity") <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
<*> switch <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
(short 'c' <> long "cache" <> help "Cache downloads in ~/.ghcup/cache"
)
<*> (optional <*> (optional
(option (option
(eitherReader parseUri) (eitherReader parseUri)
@ -198,35 +235,29 @@ opts =
) )
) )
) )
<*> switch <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
(short 'n' <> long "no-verify" <> help <*> optional (option
"Skip tarball checksum verification"
)
<*> option
(eitherReader keepOnParser) (eitherReader keepOnParser)
( long "keep" ( long "keep"
<> metavar "<always|errors|never>" <> metavar "<always|errors|never>"
<> help <> help
"Keep build directories? (default: errors)" "Keep build directories? (default: errors)"
<> value Errors
<> hidden <> hidden
) ))
<*> option <*> optional (option
(eitherReader downloaderParser) (eitherReader downloaderParser)
( long "downloader" ( long "downloader"
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>" <> metavar "<internal|curl|wget>"
<> help <> help
"Downloader to use (default: internal)" "Downloader to use (default: internal)"
<> value Internal
#else #else
<> metavar "<curl|wget>" <> metavar "<curl|wget>"
<> help <> help
"Downloader to use (default: curl)" "Downloader to use (default: curl)"
<> value Curl
#endif #endif
<> hidden <> hidden
) ))
<*> com <*> com
where where
parseUri s' = parseUri s' =
@ -343,20 +374,20 @@ com =
installToolFooter = [s|Discussion: installToolFooter = [s|Discussion:
Installs GHC or cabal. When no command is given, installs GHC Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag. 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 :: String
setFooter = [s|Discussion: setFooter = [s|Discussion:
Sets the currently active GHC or cabal version. When no command is given, 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 defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version). 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 :: String
rmFooter = [s|Discussion: rmFooter = [s|Discussion:
Remove the given GHC or cabal version. When no command is given, Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version. 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 :: String
changeLogFooter = [s|Discussion: changeLogFooter = [s|Discussion:
@ -441,7 +472,7 @@ Examples:
installOpts :: Parser InstallOptions installOpts :: Parser InstallOptions
installOpts = installOpts =
(\p (u, v) -> InstallOptions v p u) (\p (u, v) b -> InstallOptions v p u b)
<$> (optional <$> (optional
(option (option
(eitherReader platformParser) (eitherReader platformParser)
@ -466,6 +497,12 @@ installOpts =
) )
<|> ((,) <$> pure Nothing <*> optional toolVersionArgument) <|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
) )
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
setParser :: Parser (Either SetCommand SetOptions) setParser :: Parser (Either SetCommand SetOptions)
@ -635,7 +672,7 @@ Examples:
ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts = ghcCompileOpts =
(\CabalCompileOptions {..} crossTarget addConfArgs -> GHCCompileOptions { .. } (\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. }
) )
<$> cabalCompileOpts <$> cabalCompileOpts
<*> (optional <*> (optional
@ -647,6 +684,12 @@ ghcCompileOpts =
) )
) )
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)")) <*> 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 :: Parser CabalCompileOptions
cabalCompileOpts = cabalCompileOpts =
@ -856,15 +899,46 @@ bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
toSettings :: Options -> IO Settings toSettings :: Options -> IO AppState
toSettings Options {..} = do toSettings options = do
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
dirs <- getDirs 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 upgradeOptsP :: Parser UpgradeOpts
@ -931,6 +1005,7 @@ main = do
ENV variables: ENV variables:
* TMPDIR: where ghcup does the work (unpacking, building, ...) * TMPDIR: where ghcup does the work (unpacking, building, ...)
* GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) * 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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|] Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@ -940,15 +1015,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer)) (footerDoc (Just $ text main_footer))
) )
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt appstate@AppState{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir -- create ~/.ghcup dir
createDirRecursive' baseDir createDirRecursive' baseDir
-- logger interpreter -- logger interpreter
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|] logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose { lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
, rawOutter = appendFile logfile , rawOutter = appendFile logfile
} }
@ -959,9 +1034,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters -- -- Effect interpreters --
------------------------- -------------------------
let runInstTool' settings' = let runInstTool' appstate' =
runLogger runLogger
. flip runReaderT settings' . flip runReaderT appstate'
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -980,12 +1055,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TarDirDoesNotExist , TarDirDoesNotExist
] ]
let runInstTool = runInstTool' settings let runInstTool = runInstTool' appstate
let let
runSetGHC = runSetGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
@ -995,7 +1070,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetCabal = runSetCabal =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1004,26 +1079,26 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetHLS = runSetHLS =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
] ]
let runListGHC = runLogger . flip runReaderT settings let runListGHC = runLogger . flip runReaderT appstate
let runRm = let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT appstate . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC = let runCompileGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1044,7 +1119,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runUpgrade = let runUpgrade =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
@ -1072,10 +1147,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(GHCupInfo treq dls) <- (GHCupInfo treq dls) <-
( runLogger ( runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError] . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF (maybe GHCupURL OwnSource optUrlSource) $ getDownloadsF (urlSource settings)
) )
>>= \case >>= \case
VRight r -> pure r VRight r -> pure r
@ -1086,7 +1161,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case optCommand of case optCommand of
Upgrade _ _ -> pure () Upgrade _ _ -> pure ()
_ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq _ -> runLogger $ flip runReaderT appstate $ checkForUpdates dls pfreq
@ -1099,12 +1174,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) 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 v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
(fromMaybe pfreq instPlatform) (fromMaybe pfreq instPlatform)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@ -1115,7 +1192,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of case keepDirs settings of
Never -> runLogger ($(logError) [i|Build failed with #{e}|]) Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> 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. Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
@ -1140,7 +1217,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) 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 v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist liftE $ installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@ -1173,7 +1250,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer HLS v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) 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 v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist liftE $ installHLSBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@ -1272,7 +1349,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of res <- case optCommand of
#if defined(BRICK) #if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess Interactive -> liftIO $ brickMain appstate optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif #endif
Install (Right iopts) -> do Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@ -1317,14 +1394,17 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 8 pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions {..}) -> Compile (CompileGHC GHCCompileOptions {..}) ->
(runCompileGHC $ liftE $ compileGHC dls (runCompileGHC $ do
(GHCTargetVersion crossTarget targetVer) liftE $ compileGHC dls
bootstrapGhc (GHCTargetVersion crossTarget targetVer)
jobs bootstrapGhc
buildConfig jobs
patchDir buildConfig
addConfArgs patchDir
pfreq addConfArgs
pfreq
when setCompile $ void $ liftE
$ setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@ -1336,7 +1416,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of case keepDirs settings of
Never -> runLogger ($(logError) [i|Build failed with #{e} Never -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir}|]) Check the logs at #{logsDir}|])
_ -> runLogger ($(logError) [i|Build failed with #{e} _ -> runLogger ($(logError) [i|Build failed with #{e}
@ -1602,7 +1682,14 @@ printListResult raw lr = do
| otherwise -> 1 | 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 => GHCupDownloads
-> PlatformRequest -> PlatformRequest
-> m () -> m ()

9
cabal.ghc884.project
View File

@ -1,6 +1,6 @@
-- Generated by stackage-to-hackage -- 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 with-compiler: ghc-8.8.4
@ -16,17 +16,12 @@ source-repository-package
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42 tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types subdir: haskus-utils-types
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-io
source-repository-package source-repository-package
type: git type: git
location: https://github.com/hasufell/hpath.git location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2 tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-directory subdir: hpath-directory
hpath-io
source-repository-package source-repository-package
type: git type: git

7
cabal.ghc884.project.freeze
View File

@ -373,7 +373,7 @@ constraints: any.AC-Angle ==1.0,
any.bower-json ==1.0.0.1, any.bower-json ==1.0.0.1,
any.boxes ==0.1.5, any.boxes ==0.1.5,
brick +demos, brick +demos,
any.brick ==0.52.1, any.brick ==0.55,
any.brittany ==0.12.1.1, any.brittany ==0.12.1.1,
any.broadcast-chan ==0.2.1.1, any.broadcast-chan ==0.2.1.1,
any.brotli ==0.0.0.0, any.brotli ==0.0.0.0,
@ -927,6 +927,7 @@ constraints: any.AC-Angle ==1.0,
any.ghci-hexcalc ==0.1.1.0, any.ghci-hexcalc ==0.1.1.0,
any.ghcid ==0.8.7, any.ghcid ==0.8.7,
any.ghcjs-codemirror ==0.0.0.2, any.ghcjs-codemirror ==0.0.0.2,
ghcup +internal-downloader +tui,
any.ghost-buster ==0.1.1.0, any.ghost-buster ==0.1.1.0,
any.gi-atk ==2.0.21, any.gi-atk ==2.0.21,
any.gi-cairo ==1.0.23, 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-split ==1.0.0.2,
any.vector-th-unbox ==0.2.1.7, any.vector-th-unbox ==0.2.1.7,
any.verbosity ==0.4.0.0, any.verbosity ==0.4.0.0,
any.versions ==3.5.4, any.versions ==4.0.1,
any.vformat ==0.14.1.0, any.vformat ==0.14.1.0,
any.vformat-aeson ==0.1.0.1, any.vformat-aeson ==0.1.0.1,
any.vformat-time ==0.1.0.0, any.vformat-time ==0.1.0.0,
any.void ==0.7.3, any.void ==0.7.3,
any.vty ==5.28.2, any.vty ==5.30,
any.wai ==3.2.2.1, any.wai ==3.2.2.1,
any.wai-app-static ==3.1.7.2, any.wai-app-static ==3.1.7.2,
any.wai-conduit ==3.0.0.4, any.wai-conduit ==3.0.0.4,

61
config.yaml Normal file
View File

@ -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"

7
ghcup.cabal
View File

@ -72,6 +72,9 @@ common bz2
common case-insensitive common case-insensitive
build-depends: case-insensitive >=1.2.1.0 build-depends: case-insensitive >=1.2.1.0
common casing
build-depends: casing >=0.1.4.1
common concurrent-output common concurrent-output
build-depends: concurrent-output >=1.10.11 build-depends: concurrent-output >=1.10.11
@ -226,7 +229,7 @@ common vector
build-depends: vector >=0.12 build-depends: vector >=0.12
common versions common versions
build-depends: versions >=3.5 build-depends: versions >=4.0.1
common vty common vty
build-depends: vty >=5.28.2 build-depends: vty >=5.28.2
@ -266,6 +269,7 @@ library
, bytestring , bytestring
, bz2 , bz2
, case-insensitive , case-insensitive
, casing
, concurrent-output , concurrent-output
, containers , containers
, cryptohash-sha256 , cryptohash-sha256
@ -307,6 +311,7 @@ library
, utf8-string , utf8-string
, vector , vector
, versions , versions
, vty
, word8 , word8
, yaml , yaml
, zlib , zlib

74
lib/GHCup.hs
View File

@ -99,7 +99,7 @@ import qualified Data.Text.Encoding as E
installGHCBindist :: ( MonadFail m installGHCBindist :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -142,7 +142,7 @@ installGHCBindist dlinfo ver pfreq = do
-- build system and nothing else. -- build system and nothing else.
installPackedGHC :: ( MonadMask m installPackedGHC :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO 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 -- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else. -- build system and nothing else.
installUnpackedGHC :: ( MonadReader Settings m installUnpackedGHC :: ( MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -214,7 +214,7 @@ installUnpackedGHC path inst ver (PlatformRequest {..}) = do
installGHCBin :: ( MonadFail m installGHCBin :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -246,7 +246,7 @@ installGHCBin bDls ver pfreq = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m installCabalBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -273,7 +273,7 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver (PlatformRequest {..}) = do installCabalBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
whenM whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $ (lift (cabalInstalled ver) >>= \a -> liftIO $
@ -328,7 +328,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
-- the latest installed version. -- the latest installed version.
installCabalBin :: ( MonadMask m installCabalBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -361,7 +361,7 @@ installCabalBin bDls ver pfreq = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m installHLSBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -388,7 +388,7 @@ installHLSBindist :: ( MonadMask m
installHLSBindist dlinfo ver (PlatformRequest {..}) = do installHLSBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
$ (throwE $ AlreadyInstalled HLS ver) $ (throwE $ AlreadyInstalled HLS ver)
@ -452,7 +452,7 @@ installHLSBindist dlinfo ver (PlatformRequest {..}) = do
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m installHLSBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -498,7 +498,7 @@ installHLSBin bDls ver pfreq = do
-- --
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@ -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader Settings m setGHC :: ( MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -515,7 +515,7 @@ setGHC ver sghc = do
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)))
-- symlink destination -- symlink destination
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
@ -556,12 +556,12 @@ setGHC ver sghc = do
where where
symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m) symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
=> Path Abs => Path Abs
-> ByteString -> ByteString
-> m () -> m ()
symlinkShareDir ghcdir verBS = do symlinkShareDir ghcdir verBS = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
let destdir = baseDir let destdir = baseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
@ -579,7 +579,7 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -- | 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 => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setCabal ver = do setCabal ver = do
@ -587,7 +587,7 @@ setCabal ver = do
targetFile <- parseRel ("cabal-" <> verBS) targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination -- symlink destination
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile)) whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
@ -613,7 +613,7 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks. -- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m setHLS :: ( MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -622,7 +622,7 @@ setHLS :: ( MonadCatch m
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setHLS ver = do setHLS ver = do
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
-- Delete old symlinks, since these might have different ghc versions than the -- Delete old symlinks, since these might have different ghc versions than the
@ -703,7 +703,7 @@ listVersions :: ( MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m , MonadReader AppState m
) )
=> GHCupDownloads => GHCupDownloads
-> Maybe Tool -> Maybe Tool
@ -736,7 +736,7 @@ listVersions av lt criteria pfreq = do
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers) pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
where 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
@ -778,7 +778,7 @@ listVersions av lt criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|] [i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayCabals avTools = do strayCabals avTools = do
@ -806,7 +806,7 @@ listVersions av lt criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|] [i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayHLS avTools = do strayHLS avTools = do
@ -835,7 +835,7 @@ listVersions av lt criteria pfreq = do
pure Nothing pure Nothing
-- NOTE: this are not cross ones, because no bindists -- 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 toListResult t (v, tags) = case t of
GHC -> do GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av 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. -- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version). -- older version).
rmGHCVer :: ( MonadReader Settings m rmGHCVer :: ( MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -942,7 +942,7 @@ rmGHCVer ver = do
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
liftIO liftIO
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
@ -952,7 +952,7 @@ rmGHCVer ver = do
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version). -- 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 => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmCabalVer ver = do rmCabalVer ver = do
@ -960,7 +960,7 @@ rmCabalVer ver = do
cSet <- lift $ cabalSet cSet <- lift $ cabalSet
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
@ -975,7 +975,7 @@ rmCabalVer ver = do
-- | Delete a hls version. Will try to fix the hls symlinks -- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version). -- 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 => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmHLSVer ver = do rmHLSVer ver = do
@ -983,7 +983,7 @@ rmHLSVer ver = do
isHlsSet <- lift $ hlsSet isHlsSet <- lift $ hlsSet
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f) 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 => Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
let diBaseDir = baseDir let diBaseDir = baseDir
let diBinDir = binDir let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir diGHCDir <- lift ghcupGHCBaseDir
@ -1034,7 +1034,7 @@ getDebugInfo = do
-- | Compile a GHC from source. This behaves wrt symlinks and installation -- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'. -- the same as 'installGHCBin'.
compileGHC :: ( MonadMask m compileGHC :: ( MonadMask m
, MonadReader Settings m , MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadLogger m , MonadLogger m
@ -1135,7 +1135,7 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO HADDOCK_DOCS = NO
Stage1Only = YES|] Stage1Only = YES|]
compileBindist :: ( MonadReader Settings m compileBindist :: ( MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
@ -1153,7 +1153,7 @@ Stage1Only = YES|]
lift $ $(logInfo) [i|configuring build|] lift $ $(logInfo) [i|configuring build|]
liftE $ checkBuildConfig liftE $ checkBuildConfig
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
@ -1270,7 +1270,7 @@ Stage1Only = YES|]
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided. -- if no path is provided.
upgradeGHCup :: ( MonadMask m upgradeGHCup :: ( MonadMask m
, MonadReader Settings m , MonadReader AppState m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -1292,7 +1292,7 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup dls mtarget force pfreq = do upgradeGHCup dls mtarget force pfreq = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate 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 -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: ( MonadReader Settings m postGHCInstall :: ( MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m

90
lib/GHCup/Download.hs
View File

@ -83,9 +83,9 @@ import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
#endif #endif
import qualified Data.Text.Encoding as E 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-<format-ver>.yaml -- | Downloads the download information! But only if we need to ;P
getDownloadsF :: ( FromJSONKey Tool getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
, FromJSON VersionInfo , FromJSON VersionInfo
@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader Settings m , MonadReader AppState m
) )
=> URLSource => URLSource
-> Excepts -> Excepts
@ -123,17 +123,24 @@ getDownloadsF :: ( FromJSONKey Tool
GHCupInfo GHCupInfo
getDownloadsF urlSource = do getDownloadsF urlSource = do
case urlSource of case urlSource of
GHCupURL -> GHCupURL -> liftE getBase
liftE (OwnSource url) -> do
$ handleIO (\_ -> readFromCache) bs <- reThrowAll DownloadFailed $ downloadBS url
$ catchE @_ @'[JSONError , FileDoesNotExistError] lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
(\(DownloadFailed _) -> readFromCache) (OwnSpec av) -> pure av
$ getDownloads urlSource (AddSource (Left ext)) -> do
(OwnSource _) -> liftE $ getDownloads urlSource base <- liftE getBase
(OwnSpec _) -> liftE $ getDownloads urlSource 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 where
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do readFromCache = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn) lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|] [i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL let path = view pathL' ghcupURL
@ -145,32 +152,25 @@ getDownloadsF urlSource = do
$ readFile yaml_file $ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) 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 mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
getDownloads :: ( FromJSONKey Tool -> GHCupInfo -- ^ extension overwriting the base
, FromJSONKey Version -> GHCupInfo
, FromJSON VersionInfo mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) =
, MonadIO m let new = M.mapWithKey (\k a -> case M.lookup k ext of
, MonadCatch m Just a' -> M.union a' a
, MonadLogger m Nothing -> a
, MonadThrow m ) base
, MonadFail m in GHCupInfo tr new
, 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
where
-- First check if the json file is in the ~/.ghcup/cache dir -- 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 -- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it. -- last 5 minutes, just reuse it.
@ -185,7 +185,7 @@ getDownloads urlSource = do
, MonadIO m1 , MonadIO m1
, MonadFail m1 , MonadFail m1
, MonadLogger m1 , MonadLogger m1
, MonadReader Settings m1 , MonadReader AppState m1
) )
=> URI => URI
-> Excepts -> Excepts
@ -200,7 +200,7 @@ getDownloads urlSource = do
m1 m1
L.ByteString L.ByteString
smartDl uri' = do smartDl uri' = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri' let path = view pathL' uri'
json_file <- (cacheDir </>) <$> urlBaseName path json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
@ -311,7 +311,7 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
-- --
-- The file must not exist. -- The file must not exist.
download :: ( MonadMask m download :: ( MonadMask m
, MonadReader Settings m , MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -383,7 +383,7 @@ downloadCached :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m , MonadReader AppState m
) )
=> DownloadInfo => DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
@ -392,7 +392,7 @@ downloadCached dli mfn = do
cache <- lift getCache cache <- lift getCache
case cache of case cache of
True -> do True -> do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cacheDir </> fn let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
@ -416,7 +416,7 @@ downloadCached dli mfn = do
-- | This is used for downloading the JSON. -- | 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 => URI
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
@ -473,12 +473,12 @@ downloadBS uri'
#endif #endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m) checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo => DownloadInfo
-> Path Abs -> Path Abs
-> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
checkDigest dli file = do checkDigest dli file = do
verify <- lift ask <&> (not . noVerify) verify <- lift ask <&> (not . noVerify . settings)
when verify $ do when verify $ do
p' <- toFilePath <$> basename file p' <- toFilePath <$> basename file
lift $ $(logInfo) [i|verifying digest of: #{p'}|] lift $ $(logInfo) [i|verifying digest of: #{p'}|]

68
lib/GHCup/Types.hs
View File

@ -21,6 +21,7 @@ import URI.ByteString
import qualified Data.Text as T import qualified Data.Text as T
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty
@ -190,27 +191,82 @@ data TarDir = RealDir (Path Rel)
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URI | OwnSource URI
| OwnSpec GHCupInfo | OwnSpec GHCupInfo
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
deriving (GHC.Generic, Show) 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 data Settings = Settings
{ -- set by user { cache :: Bool
cache :: Bool
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
, urlSource :: URLSource
-- set on app start
, dirs :: Dirs
} }
deriving Show deriving (Show, GHC.Generic)
data Dirs = Dirs data Dirs = Dirs
{ baseDir :: Path Abs { baseDir :: Path Abs
, binDir :: Path Abs , binDir :: Path Abs
, cacheDir :: Path Abs , cacheDir :: Path Abs
, logsDir :: Path Abs , logsDir :: Path Abs
, confDir :: Path Abs
} }
deriving Show deriving Show

9
lib/GHCup/Types/JSON.hs
View File

@ -33,14 +33,17 @@ import Data.Versions
import Data.Word8 import Data.Word8
import HPath import HPath
import URI.ByteString import URI.ByteString
import Text.Casing
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Graphics.Vty as Vty
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
@ -50,6 +53,12 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements 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 instance ToJSON Tag where
toJSON Latest = String "Latest" toJSON Latest = String "Latest"

85
lib/GHCup/Utils.hs
View File

@ -50,6 +50,7 @@ import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
import Data.List import Data.List
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.List.Split import Data.List.Split
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
@ -99,21 +100,21 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool. -- | 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. => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion -> GHCTargetVersion
-> m ByteString -> m ByteString
ghcLinkDestination tool ver = do ghcLinkDestination tool ver = do
Settings {dirs = Dirs {..}} <- ask AppState { dirs = Dirs {..} } <- ask
t <- parseRel tool t <- parseRel tool
ghcd <- ghcupGHCDir ver ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t)) pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- | 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 rmMinorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask AppState { dirs = Dirs {..} } <- ask
files <- liftIO $ findFiles' files <- liftIO $ findFiles'
binDir binDir
@ -130,11 +131,11 @@ rmMinorSymlinks GHCTargetVersion {..} = do
-- | Removes the set ghc version for the given target, if any. -- | 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 => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain target = do rmPlain target = do
Settings {dirs = Dirs {..}} <- lift ask AppState { dirs = Dirs {..} } <- lift ask
mtv <- lift $ ghcSet target mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
@ -149,11 +150,11 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- | 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 => GHCTargetVersion
-> m () -> m ()
rmMajorSymlinks GHCTargetVersion {..} = do rmMajorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask AppState { dirs = Dirs {..} } <- ask
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
@ -179,26 +180,26 @@ rmMajorSymlinks GHCTargetVersion {..} = do
-- | Whethe the given GHC versin is installed. -- | 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 ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source. -- | 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 ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile) liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | 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 => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
ghcSet mtarget = do ghcSet mtarget = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget) ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
let ghcBin = binDir </> ghc let ghcBin = binDir </> ghc
@ -231,7 +232,7 @@ ghcLinkVersion bs = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left. -- 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 getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
@ -241,10 +242,10 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | 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] => m [Either (Path Rel) Version]
getInstalledCabals = do getInstalledCabals = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
@ -257,16 +258,16 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | 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 cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers pure $ elem ver $ vers
-- Return the currently set cabal version, if any. -- 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 cabalSet = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|] let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if if
@ -303,10 +304,10 @@ cabalSet = do
-- | Get all installed hls, by matching on -- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -- @~\/.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] => m [Either (Path Rel) Version]
getInstalledHLSs = do getInstalledHLSs = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -326,7 +327,7 @@ getInstalledHLSs = do
-- | Whether the given HLS version is installed. -- | 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 hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers pure $ elem ver $ vers
@ -334,9 +335,9 @@ hlsInstalled ver = do
-- Return the currently set hls version, if any. -- 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 hlsSet = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|] let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
@ -357,7 +358,7 @@ hlsSet = do
-- | Return the GHC versions the currently selected HLS supports. -- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader Settings m hlsGHCVersions :: ( MonadReader AppState m
, MonadIO m , MonadIO m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
@ -383,11 +384,11 @@ hlsGHCVersions = do
-- | Get all server binaries for an hls version, if any. -- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader Settings m, MonadIO m) hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
=> Version => Version
-> m [Path Rel] -> m [Path Rel]
hlsServerBinaries ver = do hlsServerBinaries ver = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
@ -399,11 +400,11 @@ hlsServerBinaries ver = do
-- | Get the wrapper binary for an hls version, if any. -- | 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 => Version
-> m (Maybe (Path Rel)) -> m (Maybe (Path Rel))
hlsWrapperBinary ver = do hlsWrapperBinary ver = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
@ -420,7 +421,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any. -- | 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 hlsAllBinaries ver = do
hls <- hlsServerBinaries ver hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver wrapper <- hlsWrapperBinary ver
@ -428,9 +429,9 @@ hlsAllBinaries ver = do
-- | Get the active symlinks for hls. -- | 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 hlsSymlinks = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -455,7 +456,7 @@ hlsSymlinks = do
-- | Extract (major, minor) from any version. -- | Extract (major, minor) from any version.
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int) getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {..} = case _vChunks of 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" _ -> 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. -- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`. -- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m) getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> Int -- ^ major version component => Int -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple -> Maybe Text -- ^ the target triple
@ -603,16 +604,16 @@ getLatestBaseVersion av pvpVer =
----------------------- -----------------------
--[ Settings Getter ]-- --[ AppState Getter ]--
----------------------- -----------------------
getCache :: MonadReader Settings m => m Bool getCache :: MonadReader AppState m => m Bool
getCache = ask <&> cache getCache = ask <&> cache . settings
getDownloader :: MonadReader Settings m => m Downloader getDownloader :: MonadReader AppState m => m Downloader
getDownloader = ask <&> downloader getDownloader = ask <&> downloader . settings
@ -633,7 +634,7 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Returns unversioned relative files, e.g.: -- Returns unversioned relative files, e.g.:
-- --
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -- - @["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 => GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do ghcToolFiles ver = do
@ -686,7 +687,7 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make. -- | 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] => [ByteString]
-> Maybe (Path Abs) -> Maybe (Path Abs)
-> m (Either ProcessError ()) -> m (Either ProcessError ())
@ -739,13 +740,13 @@ getChangeLog dls tool (Right tag) =
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed -- 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) => Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception -> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do runBuildAction bdir instdir action = do
Settings {..} <- lift ask AppState { settings = Settings {..} } <- lift ask
let exAction = do let exAction = do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir

59
lib/GHCup/Utils/Dirs.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@ -14,16 +15,18 @@ Portability : POSIX
-} -}
module GHCup.Utils.Dirs module GHCup.Utils.Dirs
( getDirs ( getDirs
, ghcupConfigFile
, ghcupGHCBaseDir , ghcupGHCBaseDir
, ghcupGHCDir , ghcupGHCDir
, parseGHCupGHCDir
, mkGhcupTmpDir , mkGhcupTmpDir
, withGHCupTmpDir , parseGHCupGHCDir
, relativeSymlink , relativeSymlink
, withGHCupTmpDir
) )
where where
import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.MegaParsec import GHCup.Utils.MegaParsec
@ -34,8 +37,11 @@ import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Maybe import Data.Maybe
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import HPath import HPath
import HPath.IO import HPath.IO
import Optics import Optics
@ -49,8 +55,10 @@ import System.Posix.Env.ByteString ( getEnv
import System.Posix.FilePath hiding ( (</>) ) import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Temp.ByteString ( mkdtemp ) import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.FilePath as FP import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
@ -84,6 +92,28 @@ ghcupBaseDir = do
pure (bdir </> [rel|.ghcup|]) 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), -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin' -- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec). -- (which, sadly is not strictly xdg spec).
@ -142,27 +172,44 @@ getDirs = do
binDir <- ghcupBinDir binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
pure Dirs { .. } 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 directories ]--
------------------------- -------------------------
-- | ~/.ghcup/ghc by default. -- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs) ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
ghcupGHCBaseDir = do ghcupGHCBaseDir = do
Settings {..} <- ask AppState { dirs = Dirs {..} } <- ask
pure (baseDir dirs </> [rel|ghc|]) pure (baseDir </> [rel|ghc|])
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'. -- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
-- The dir may be of the form -- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3 -- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4 -- * 8.8.4
ghcupGHCDir :: (MonadReader Settings m, MonadThrow m) ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
=> GHCTargetVersion => GHCTargetVersion
-> m (Path Abs) -> m (Path Abs)
ghcupGHCDir ver = do ghcupGHCDir ver = do

4
lib/GHCup/Utils/File.hs
View File

@ -117,7 +117,7 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing 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 => ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing -> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args 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 -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
Settings {dirs = Dirs {..}, ..} <- ask AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log") logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd closeFd

4
lib/GHCup/Utils/Logger.hs
View File

@ -65,9 +65,9 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr 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 initGHCupFileLogging context = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let logfile = logsDir </> context let logfile = logsDir </> context
liftIO $ do liftIO $ do
createDirRecursive' logsDir createDirRecursive' logsDir

3
lib/GHCup/Utils/MegaParsec.hs
View File

@ -25,6 +25,7 @@ import Data.Text ( Text )
import Data.Versions import Data.Versions
import Data.Void import Data.Void
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
@ -90,6 +91,8 @@ ghcTargetVerP =
(Digits _) -> True (Digits _) -> True
(Str _) -> False (Str _) -> False
) )
. fmap NE.toList
. NE.toList
$ (_vChunks v) $ (_vChunks v)
if startsWithDigists && not (isJust (_vEpoch v)) if startsWithDigists && not (isJust (_vEpoch v))
then pure $ prettyVer v then pure $ prettyVer v

2
lib/GHCup/Utils/Version/QQ.hs
View File

@ -42,6 +42,8 @@ deriving instance Data SemVer
deriving instance Lift SemVer deriving instance Lift SemVer
deriving instance Data Mess deriving instance Data Mess
deriving instance Lift Mess deriving instance Lift Mess
deriving instance Data MChunk
deriving instance Lift MChunk
deriving instance Data PVP deriving instance Data PVP
deriving instance Lift PVP deriving instance Lift PVP
deriving instance Lift VSep deriving instance Lift VSep

2
stack.yaml
View File

@ -47,6 +47,7 @@ extra-deps:
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138 - streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248 - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- tar-bytestring-0.6.3.2@sha256:88f29bed56b688c543a4cb3986402d64b360f76b3fd9b88ac618b8344f8da712,5715 - tar-bytestring-0.6.3.2@sha256:88f29bed56b688c543a4cb3986402d64b360f76b3fd9b88ac618b8344f8da712,5715
- versions-4.0.1@sha256:0f644c1587d38f0eb3c3fe364bf1822424db43cbd4d618d0e21473b062c45239,1936
- vty-5.30@sha256:4af3938d7b9e6096e222bf52d0ea5d39873bc6fe19febd34106906306af13730,20857 - vty-5.30@sha256:4af3938d7b9e6096e222bf52d0ea5d39873bc6fe19febd34106906306af13730,20857
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
@ -59,6 +60,7 @@ flags:
ghcup: ghcup:
tui: true tui: true
internal-downloader: true
system-ghc: true system-ghc: true
compiler: ghc-8.8.4 compiler: ghc-8.8.4