Compare commits

...

24 Commits

Author SHA1 Message Date
e74e746213 Trim whitespaces wrt #282 2021-11-13 20:35:50 +01:00
065f9c4965 Fix compile HLS CI 2021-11-13 16:56:38 +01:00
32f3c36589 Set HOMEBREW_TEMP to something shorter
This fixes unix socket errors, because there's a max path length for
those.
2021-11-13 16:53:31 +01:00
c2a8d39fb4 Bump to 0.1.17.4 2021-11-12 20:52:08 +01:00
f08cbe70fb Merge branch 'issue-281' 2021-11-12 20:42:43 +01:00
a9630d0802 Cooler patching 2021-11-12 19:52:00 +01:00
c5c6c431b5 Allow remote URIs for --cabal-project-local wrt #281 2021-11-12 19:05:13 +01:00
71d78d2d72 Update cabal.project 2021-11-12 19:04:46 +01:00
ccecda2eff Merge branch 'dynamic-hls' 2021-11-12 17:57:15 +01:00
3a5f8d6139 Fix build on windows 2021-11-12 15:01:24 +01:00
74e0f39bc2 Fix stack.yaml 2021-11-12 01:28:40 +01:00
274978a8a7 Allow to pass cabal args to 'compile hls'
This breaks the existing cli interface, but whatever.
2021-11-12 01:13:57 +01:00
8eea9bd6a5 Prefer forM_ when possible 2021-11-12 01:04:27 +01:00
626a2dd020 More debug logging 2021-11-12 01:01:21 +01:00
6b6ce221e0 Use patched haskus-utils-variant, fixing applicative instance 2021-11-12 00:57:39 +01:00
d038c361c0 Revert "Fix HLS rebuilds"
This reverts commit 8e8198546f.
2021-11-11 21:40:02 +01:00
c05876cc60 Fix build with ghc-8.6.5 2021-11-02 19:53:22 +01:00
b9c4c9a0b7 Fix hlint 2021-11-02 10:57:27 +01:00
6697e804ee Merge branch 'fix-ghc-version-parser' 2021-11-02 10:56:21 +01:00
2c57def8f1 Fix parsing of atypical ghc versions 2021-11-02 01:22:06 +01:00
62b16e957b Merge branch 'issue-276' 2021-10-30 14:17:52 +02:00
18d7bdd85c Merge branch 'issue-278' 2021-10-30 14:17:11 +02:00
190b5dedba Allow to control the metadata cache, fixes #278 2021-10-30 14:16:45 +02:00
886e45f788 Update hie.yaml 2021-10-30 13:47:45 +02:00
28 changed files with 299 additions and 141 deletions

View File

@@ -186,8 +186,8 @@ variables:
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
- mkdir -p $CI_PROJECT_DIR/.brew_logs - mkdir -p $CI_PROJECT_DIR/.brew_logs
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
- mkdir -p $CI_PROJECT_DIR/.brew_tmp - mkdir -p /private/tmp/.brew_tmp
- export HOMEBREW_TEMP=$CI_PROJECT_DIR/.brew_tmp - export HOMEBREW_TEMP=/private/tmp/.brew_tmp
# update and install packages # update and install packages
- brew update - brew update
@@ -545,8 +545,8 @@ release:darwin:aarch64:
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
- mkdir -p $CI_PROJECT_DIR/.brew_logs - mkdir -p $CI_PROJECT_DIR/.brew_logs
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
- mkdir -p $CI_PROJECT_DIR/.brew_tmp - mkdir -p /private/tmp/.brew_tmp
- export HOMEBREW_TEMP=$CI_PROJECT_DIR/.brew_tmp - export HOMEBREW_TEMP=/private/tmp/.brew_tmp
# update and install packages # update and install packages
- brew update - brew update

View File

@@ -12,4 +12,8 @@ if [ "${OS}" = "WINDOWS" ] ; then
rm -Rf /c/ghcup rm -Rf /c/ghcup
fi fi
if [ "${OS}" = "DARWIN" ] ; then
rm -Rf /private/tmp/.brew_tmp
fi
exit 0 exit 0

View File

@@ -43,7 +43,7 @@ cabal --version
eghcup debug-info eghcup debug-info
eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} ${GHC_VERSION} eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} --ghc ${GHC_VERSION}
[ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version` = "${HLS_TARGET_VERSION}" ] || [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version | sed 's/.0$//'` = "${HLS_TARGET_VERSION}" ] [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version` = "${HLS_TARGET_VERSION}" ] || [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version | sed 's/.0$//'` = "${HLS_TARGET_VERSION}" ]

View File

@@ -1,5 +1,13 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.17.4 -- 2021-11-13
* add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)
* make upgrading ghcup in TUI more pleasant wrt [#276](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/276)
* fix parsing of atypical GHC versions (e.g. `8.10.5-patch1`)
* fix compiling HLS dynamically linked, also see [#245](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/245)
* redo (and break) some of the `ghcup compile <tool>` interface, improving patch options and setting custom cabal.project files
## 0.1.17.3 -- 2021-10-27 ## 0.1.17.3 -- 2021-10-27
* clean up during unpack failures as well * clean up during unpack failures as well

View File

@@ -27,6 +27,9 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
) )
import Codec.Archive import Codec.Archive
import Control.Exception.Safe import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
@@ -556,17 +559,7 @@ settings' = unsafePerformIO $ do
, fileOutter = \_ -> pure () , fileOutter = \_ -> pure ()
, fancyColors = True , fancyColors = True
} }
newIORef $ AppState (Settings { cache = True newIORef $ AppState defaultSettings
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
, urlSource = GHCupURL
, noNetwork = False
, gpgSetting = GPGNone
, noColor = False
, ..
})
dirs dirs
defaultKeyBindings defaultKeyBindings
(GHCupInfo mempty mempty mempty) (GHCupInfo mempty mempty mempty)

View File

@@ -67,6 +67,7 @@ data Options = Options
-- global options -- global options
optVerbose :: Maybe Bool optVerbose :: Maybe Bool
, optCache :: Maybe Bool , optCache :: Maybe Bool
, optMetaCache :: Maybe Integer
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs , optKeepDirs :: Maybe KeepDirs
@@ -105,6 +106,7 @@ opts =
Options Options
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)") <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)") <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
<*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
<*> optional <*> optional
(option (option
(eitherReader parseUri) (eitherReader parseUri)

View File

@@ -89,6 +89,18 @@ toolVersionArgument criteria tool =
mv _ = "VERSION|TAG" mv _ = "VERSION|TAG"
toolVersionOption :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionOption criteria tool =
option (eitherReader toolVersionEither)
( sh tool
<> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
where
sh (Just GHC) = long "ghc" <> metavar "GHC_VERSION|TAG"
sh (Just HLS) = long "hls" <> metavar "HLS_VERSION|TAG"
sh _ = long "version" <> metavar "VERSION|TAG"
versionParser :: Parser GHCTargetVersion versionParser :: Parser GHCTargetVersion
versionParser = option versionParser = option
(eitherReader tVersionEither) (eitherReader tVersionEither)
@@ -196,8 +208,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
] ]
bindistParser :: String -> Either String URI uriParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString
absolutePathParser :: FilePath -> Either String FilePath absolutePathParser :: FilePath -> Either String FilePath
@@ -246,18 +258,6 @@ criteriaParser s' | t == T.pack "installed" = Right ListInstalled
where t = T.toLower (T.pack s') where t = T.toLower (T.pack s')
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP' <|> toolP
where
verP' = ToolVersion <$> versionParser
toolP =
ToolTag
<$> option
(eitherReader tagEither)
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
keepOnParser :: String -> Either String KeepDirs keepOnParser :: String -> Either String KeepDirs
keepOnParser s' | t == T.pack "always" = Right Always keepOnParser s' | t == T.pack "always" = Right Always
@@ -299,7 +299,7 @@ tagCompleter tool add = listIOCompleter $ do
, fancyColors = False , fancyColors = False
} }
let appState = LeanAppState let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True GPGNone False) (defaultSettings { noNetwork = True })
dirs' dirs'
defaultKeyBindings defaultKeyBindings
loggerConfig loggerConfig
@@ -322,7 +322,7 @@ versionCompleter criteria tool = listIOCompleter $ do
, fileOutter = mempty , fileOutter = mempty
, fancyColors = False , fancyColors = False
} }
let settings = Settings True False Never Curl False GHCupURL True GPGNone False let settings = defaultSettings { noNetwork = True }
let leanAppState = LeanAppState let leanAppState = LeanAppState
settings settings
dirs' dirs'
@@ -399,7 +399,7 @@ fromVersion' (SetToolVersion v) tool = do
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_ v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi') pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (v, vi)

View File

@@ -40,6 +40,7 @@ import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
import System.FilePath (isPathSeparator) import System.FilePath (isPathSeparator)
@@ -68,7 +69,7 @@ data GHCCompileOptions = GHCCompileOptions
, bootstrapGhc :: Either Version FilePath , bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int , jobs :: Maybe Int
, buildConfig :: Maybe FilePath , buildConfig :: Maybe FilePath
, patchDir :: Maybe FilePath , patches :: Maybe (Either FilePath [URI])
, crossTarget :: Maybe Text , crossTarget :: Maybe Text
, addConfArgs :: [Text] , addConfArgs :: [Text]
, setCompile :: Bool , setCompile :: Bool
@@ -84,10 +85,11 @@ data HLSCompileOptions = HLSCompileOptions
, setCompile :: Bool , setCompile :: Bool
, ovewrwiteVer :: Maybe Version , ovewrwiteVer :: Maybe Version
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, cabalProject :: Maybe FilePath , cabalProject :: Maybe (Either FilePath URI)
, cabalProjectLocal :: Maybe FilePath , cabalProjectLocal :: Maybe URI
, patchDir :: Maybe FilePath , patches :: Maybe (Either FilePath [URI])
, targetGHCs :: [ToolVersion] , targetGHCs :: [ToolVersion]
, cabalArgs :: [Text]
} }
@@ -148,7 +150,10 @@ Examples:
These need to be available in PATH prior to compilation. These need to be available in PATH prior to compilation.
Examples: Examples:
ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|] # compile 1.4.0 for ghc 8.10.5 and 8.10.7
ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7
# compile from master for ghc 8.10.7, linking everything dynamically
ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]
ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts :: Parser GHCCompileOptions
@@ -195,13 +200,23 @@ ghcCompileOpts =
"Absolute path to build config file" "Absolute path to build config file"
) )
) )
<*> optional <*> (optional
(option (
str (fmap Right $ many $ option
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help (eitherReader uriParser)
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" (long "patch" <> metavar "PATCH_URI" <> help
"URI to a patch (https/http/file)"
)
)
<|>
(fmap Left $ option
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
) )
) )
)
<*> optional <*> optional
(option (option
str str
@@ -296,26 +311,37 @@ hlsCompileOpts =
) )
<*> optional <*> optional
(option (option
str ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
(long "cabal-project" <> metavar "CABAL_PROJECT" <> help (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
"If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over." "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
) )
) )
<*> optional <*> optional
(option (option
(eitherReader absolutePathParser) (eitherReader uriParser)
(long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
"Absolute path to a cabal.project.local to be used for the build. Will be copied over." "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
) )
) )
<*> optional <*> (optional
(option (
(eitherReader absolutePathParser) (fmap Right $ many $ option
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help (eitherReader uriParser)
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" (long "patch" <> metavar "PATCH_URI" <> help
"URI to a patch (https/http/file)"
)
)
<|>
(fmap Left $ option
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
) )
) )
<*> some (toolVersionArgument Nothing (Just GHC)) )
<*> some (toolVersionOption Nothing (Just GHC))
<*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
@@ -430,7 +456,8 @@ compile compileCommand settings runAppState runLogger = do
isolateDir isolateDir
cabalProject cabalProject
cabalProjectLocal cabalProjectLocal
patchDir patches
cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
@@ -477,7 +504,7 @@ compile compileCommand settings runAppState runLogger = do
bootstrapGhc bootstrapGhc
jobs jobs
buildConfig buildConfig
patchDir patches
addConfArgs addConfArgs
buildFlavour buildFlavour
hadrian hadrian

View File

@@ -122,6 +122,7 @@ updateSettings config' settings = do
mergeConf :: UserSettings -> Settings -> Settings mergeConf :: UserSettings -> Settings -> Settings
mergeConf UserSettings{..} Settings{..} = mergeConf UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache let cache' = fromMaybe cache uCache
metaCache' = fromMaybe metaCache uMetaCache
noVerify' = fromMaybe noVerify uNoVerify noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader downloader' = fromMaybe downloader uDownloader
@@ -129,7 +130,7 @@ updateSettings config' settings = do
urlSource' = fromMaybe urlSource uUrlSource urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting gpgSetting' = fromMaybe gpgSetting uGPGSetting
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor

View File

@@ -51,7 +51,7 @@ describe_result = $( LitE . StringL <$>
runIO (do runIO (do
CapturedProcess{..} <- do CapturedProcess{..} <- do
dirs <- liftIO getAllDirs dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False) let settings = AppState (defaultSettings { noNetwork = True })
dirs dirs
defaultKeyBindings defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing flip runReaderT settings $ executeOut "git" ["describe"] Nothing

View File

@@ -37,7 +37,7 @@ import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T import qualified Data.Text as T
@@ -187,7 +187,7 @@ installOpts tool =
<*> ( ( (,) <*> ( ( (,)
<$> optional <$> optional
(option (option
(eitherReader bindistParser) (eitherReader uriParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist" "Install the specified version from this bindist"
) )

View File

@@ -55,6 +55,7 @@ import qualified Data.ByteString as B
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified GHCup.Types as Types
@@ -72,15 +73,16 @@ toSettings options = do
where where
mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
mergeConf Options{..} UserSettings{..} noColor = mergeConf Options{..} UserSettings{..} noColor =
let cache = fromMaybe (fromMaybe False uCache) optCache let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe GPGNone uGPGSetting) optGpg gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal

View File

@@ -36,6 +36,10 @@ key-bindings:
show-all-tools: show-all-tools:
KChar: 't' KChar: 't'
# The caching for the metadata files containing download info, depending on last access time
# of the file. These usually are in '~/.ghcup/cache/ghcup-<ver>.yaml'.
meta-cache: 300 # in seconds
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code. # check the 'URLSource' type in the code.
url-source: url-source:

View File

@@ -53,6 +53,25 @@ as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
and make sure your bashrc sources the startup script and make sure your bashrc sources the startup script
(`/usr/share/bash-completion/bash_completion` on some distros). (`/usr/share/bash-completion/bash_completion` on some distros).
## Caching
GHCup has a few caching mechanisms to avoid redownloads. All cached files end up in `~/.ghcup/cache` by default.
### Downloads cache
Downloaded tarballs (such as GHC, cabal, etc.) are not cached by default unless you pass `ghcup --cache` or set caching
in your [config](#configuration) via `ghcup config set cache true`.
### Metadata cache
The metadata files (also see [github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata))
have a 5 minutes cache per default depending on the last access time of the file. That means if you run
`ghcup list` 10 times in a row, only the first time will trigger a download attempt.
### Clearing the cache
If you experience problems, consider clearing the cache via `ghcup gc --cache`.
## Compiling GHC from source ## Compiling GHC from source
Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help` Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.17.3 version: 0.1.17.4
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020
@@ -96,7 +96,7 @@ library
build-depends: build-depends:
, aeson >=1.4 , aeson >=1.4
, async >=0.8 && <2.3 , async >=0.8 && <2.3
, base >=4.13 && <5 , base >=4.12 && <5
, base16-bytestring >=0.1.1.6 && <1.1 , base16-bytestring >=0.1.1.6 && <1.1
, binary ^>=0.8.6.0 , binary ^>=0.8.6.0
, bytestring ^>=0.10 , bytestring ^>=0.10
@@ -110,7 +110,7 @@ library
, disk-free-space ^>=0.1.0.1 , disk-free-space ^>=0.1.0.1
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, haskus-utils-types ^>=1.5 , haskus-utils-types ^>=1.5
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, lzma-static ^>=5.2.5.3 , lzma-static ^>=5.2.5.3
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.1
@@ -219,7 +219,7 @@ executable ghcup
, aeson >=1.4 , aeson >=1.4
, aeson-pretty ^>=0.8.8 , aeson-pretty ^>=0.8.8
, async ^>=2.2.3 , async ^>=2.2.3
, base >=4.13 && <5 , base >=4.12 && <5
, bytestring ^>=0.10 , bytestring ^>=0.10
, cabal-plan ^>=0.7.2 , cabal-plan ^>=0.7.2
, containers ^>=0.6 , containers ^>=0.6
@@ -227,7 +227,7 @@ executable ghcup
, directory ^>=1.3.6.0 , directory ^>=1.3.6.0
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, ghcup , ghcup
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.1
, mtl ^>=2.2 , mtl ^>=2.2
@@ -287,7 +287,7 @@ test-suite ghcup-test
-fwarn-incomplete-record-updates -fwarn-incomplete-record-updates
build-depends: build-depends:
, base >=4.13 && <5 , base >=4.12 && <5
, bytestring ^>=0.10 , bytestring ^>=0.10
, containers ^>=0.6 , containers ^>=0.6
, generic-arbitrary ^>=0.1.0 , generic-arbitrary ^>=0.1.0

View File

@@ -4,7 +4,5 @@ cradle:
path: ./lib path: ./lib
- component: "ghcup:exe:ghcup" - component: "ghcup:exe:ghcup"
path: ./app/ghcup path: ./app/ghcup
- component: "ghcup:exe:ghcup-gen"
path: "./app/ghcup-gen"
- component: "ghcup:test:ghcup-test" - component: "ghcup:test:ghcup-test"
path: ./test path: ./test

View File

@@ -62,7 +62,7 @@ import Data.String ( fromString )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Format.ISO8601 import Data.Time.Format.ISO8601
import Data.Versions import Data.Versions hiding ( patch )
import Distribution.Types.Version hiding ( Version ) import Distribution.Types.Version hiding ( Version )
import Distribution.Types.PackageId import Distribution.Types.PackageId
import Distribution.Types.PackageDescription import Distribution.Types.PackageDescription
@@ -84,6 +84,7 @@ import System.IO.Error
import System.IO.Temp import System.IO.Temp
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
@@ -750,9 +751,10 @@ compileHLS :: ( MonadMask m
-> Maybe Int -> Maybe Int
-> Maybe Version -> Maybe Version
-> Maybe FilePath -> Maybe FilePath
-> Maybe FilePath -> Maybe (Either FilePath URI)
-> Maybe FilePath -> Maybe URI
-> Maybe FilePath -> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to cabal install
-> Excepts '[ NoDownload -> Excepts '[ NoDownload
, GPGError , GPGError
, DownloadFailed , DownloadFailed
@@ -763,11 +765,12 @@ compileHLS :: ( MonadMask m
, BuildFailed , BuildFailed
, NotInstalled , NotInstalled
] m Version ] m Version
compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patchdir = do compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
(workdir, tver) <- case targetHLS of (workdir, tver) <- case targetHLS of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
@@ -834,48 +837,51 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
liftE $ runBuildAction liftE $ runBuildAction
workdir workdir
Nothing Nothing
(reThrowAll @_ @'[PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let installDir = workdir </> "out" let installDir = workdir </> "out"
liftIO $ createDirRecursive' installDir liftIO $ createDirRecursive' installDir
-- apply patches -- apply patches
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir) liftE $ applyAnyPatch patches workdir
-- set up project files -- set up project files
cp <- case cabalProject of cp <- case cabalProject of
Just cp Just (Left cp)
| isAbsolute cp -> do | isAbsolute cp -> do
copyFileE cp (workdir </> "cabal.project") copyFileE cp (workdir </> "cabal.project")
pure "cabal.project" pure "cabal.project"
| otherwise -> pure (takeFileName cp) | otherwise -> pure (takeFileName cp)
Just (Right uri) -> do
tmpUnpack <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
copyFileE cp (workdir </> "cabal.project")
pure "cabal.project"
Nothing -> pure "cabal.project" Nothing -> pure "cabal.project"
forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir </> cp <.> "local") forM_ cabalProjectLocal $ \uri -> do
tmpUnpack <- lift withGHCupTmpDir
let targets = ["exe:haskell-language-server", "exe:haskell-language-server-wrapper"] cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
copyFileE cpl (workdir </> cp <.> "local")
artifacts <- forM (sort ghcs) $ \ghc -> do artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = installDir </> T.unpack (prettyVer ghc) let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' ghcInstallDir liftIO $ createDirRecursive' installDir
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
liftE $ lEM @_ @'[ProcessError] $ liftE $ lEM @_ @'[ProcessError] $
execLogged "cabal" ( [ "v2-build" execLogged "cabal" ( [ "v2-install"
, "-w" , "-w"
, "ghc-" <> T.unpack (prettyVer ghc) , "ghc-" <> T.unpack (prettyVer ghc)
, "--install-method=copy"
] ++ ] ++
maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
[ "--project-file=" <> cp [ "--overwrite-policy=always"
] ++ targets , "--disable-profiling"
, "--disable-tests"
, "--installdir=" <> ghcInstallDir
, "--project-file=" <> cp
] ++ fmap T.unpack cabalArgs ++ [
"exe:haskell-language-server"
, "exe:haskell-language-server-wrapper"]
) )
(Just workdir) "cabal" Nothing (Just workdir) "cabal" Nothing
forM_ targets $ \target -> do
let cabal = "cabal"
args = ["list-bin", target]
CapturedProcess{..} <- lift $ executeOut cabal args (Just workdir)
case _exitCode of
ExitFailure i -> throwE (NonZeroExit i cabal args)
_ -> pure ()
let cbin = stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
copyFileE cbin (ghcInstallDir </> takeFileName cbin)
pure ghcInstallDir pure ghcInstallDir
forM_ artifacts $ \artifact -> do forM_ artifacts $ \artifact -> do
@@ -1102,7 +1108,7 @@ setGHC ver sghc = do
pure $ Just (file <> "-" <> verS) pure $ Just (file <> "-" <> verS)
-- create symlink -- create symlink
forM mTargetFile $ \targetFile -> do forM_ mTargetFile $ \targetFile -> do
let fullF = binDir </> targetFile <> exeExt let fullF = binDir </> targetFile <> exeExt
fileWithExt = file <> exeExt fileWithExt = file <> exeExt
destL <- lift $ ghcLinkDestination fileWithExt ver destL <- lift $ ghcLinkDestination fileWithExt ver
@@ -1574,7 +1580,7 @@ listVersions lt' criteria = do
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
currentGHCup av = currentGHCup av =
let currentVer = fromJust $ pvpToVersion ghcUpVer let currentVer = fromJust $ pvpToVersion ghcUpVer ""
listVer = Map.lookup currentVer av listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av recommendedVer = fst <$> headOf (getTagged Latest) av
@@ -2090,7 +2096,7 @@ compileGHC :: ( MonadMask m
-> Either Version FilePath -- ^ version to bootstrap with -> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs -> Maybe Int -- ^ jobs
-> Maybe FilePath -- ^ build config -> Maybe FilePath -- ^ build config
-> Maybe FilePath -- ^ patch directory -> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour -> Maybe String -- ^ build flavour
-> Bool -> Bool
@@ -2119,7 +2125,7 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir
= do = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -2143,7 +2149,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
workdir <- maybe (pure tmpUnpack) workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack) (liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo) (view dlSubdir dlInfo)
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir) liftE $ applyAnyPatch patches workdir
pure (workdir, tmpUnpack, tver) pure (workdir, tmpUnpack, tver)
@@ -2151,7 +2157,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Right GitBranch{..} -> do Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH] DownloadFailed $ do tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ] lEM $ git [ "init" ]
@@ -2171,7 +2177,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack) liftE $ applyAnyPatch patches tmpUnpack
lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut CapturedProcess {..} <- lift $ makeOut
@@ -2505,6 +2511,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
execWithGhcEnv :: ( MonadReader env m execWithGhcEnv :: ( MonadReader env m
, HasSettings env , HasSettings env
, HasDirs env , HasDirs env
, HasLog env
, MonadIO m , MonadIO m
, MonadThrow m) , MonadThrow m)
=> FilePath -- ^ thing to execute => FilePath -- ^ thing to execute
@@ -2576,7 +2583,7 @@ upgradeGHCup mtarget force' = do
lift $ logInfo "Upgrading GHCup..." lift $ logInfo "Upgrading GHCup..."
let latestVer = fromJust $ fst <$> getLatest dls GHCup let latestVer = fromJust $ fst <$> getLatest dls GHCup
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
@@ -2845,3 +2852,25 @@ rmTmp = do
let p = tmpdir </> f let p = tmpdir </> f
logDebug $ "rm -rf " <> T.pack p logDebug $ "rm -rf " <> T.pack p
rmPathForcibly p rmPathForcibly p
applyAnyPatch :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadCatch m
, MonadResource m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> Maybe (Either FilePath [URI])
-> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- lift withGHCupTmpDir
forM_ uris $ \uri -> do
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
liftE $ applyPatch patch workdir

View File

@@ -242,14 +242,18 @@ getBase uri = do
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
currentTime <- liftIO getCurrentTime currentTime <- liftIO getCurrentTime
Dirs { cacheDir } <- lift getDirs Dirs { cacheDir } <- lift getDirs
Settings { metaCache } <- lift getSettings
-- for local files, let's short-circuit and ignore access time -- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
| e -> do | e -> do
accessTime <- liftIO $ getAccessTime json_file accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
let cacheInterval = fromInteger metaCache
lift $ logDebug $ "last access was " <> T.pack (show sinceLastAccess) <> " ago, cache interval is " <> T.pack (show cacheInterval)
-- access time won't work on most linuxes, but we can try regardless -- access time won't work on most linuxes, but we can try regardless
if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) -> if | metaCache <= 0 -> dlWithMod currentTime json_file
| (sinceLastAccess > cacheInterval) ->
-- no access in last 5 minutes, re-check upstream mod time -- no access in last 5 minutes, re-check upstream mod time
dlWithMod currentTime json_file dlWithMod currentTime json_file
| otherwise -> pure json_file | otherwise -> pure json_file

View File

@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@@ -27,6 +28,9 @@ import GHCup.Utils.Logger
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad

View File

@@ -294,6 +294,7 @@ instance NFData (URIRef Absolute) where
data UserSettings = UserSettings data UserSettings = UserSettings
{ uCache :: Maybe Bool { uCache :: Maybe Bool
, uMetaCache :: Maybe Integer
, uNoVerify :: Maybe Bool , uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool , uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs , uKeepDirs :: Maybe KeepDirs
@@ -306,12 +307,13 @@ data UserSettings = UserSettings
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
UserSettings { UserSettings {
uCache = Just cache uCache = Just cache
, uMetaCache = Just metaCache
, uNoVerify = Just noVerify , uNoVerify = Just noVerify
, uVerbose = Just verbose , uVerbose = Just verbose
, uKeepDirs = Just keepDirs , uKeepDirs = Just keepDirs
@@ -335,6 +337,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
} }
in UserSettings { in UserSettings {
uCache = Just cache uCache = Just cache
, uMetaCache = Just metaCache
, uNoVerify = Just noVerify , uNoVerify = Just noVerify
, uVerbose = Just verbose , uVerbose = Just verbose
, uKeepDirs = Just keepDirs , uKeepDirs = Just keepDirs
@@ -410,6 +413,7 @@ instance NFData LeanAppState
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, metaCache :: Integer
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
@@ -421,6 +425,12 @@ data Settings = Settings
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False
instance NFData Settings instance NFData Settings
data Dirs = Dirs data Dirs = Dirs

View File

@@ -59,6 +59,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Bifunctor ( first )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
@@ -66,7 +67,7 @@ import Data.List
import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.Maybe import Data.Maybe
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions hiding ( patch )
import GHC.IO.Exception import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
@@ -110,8 +111,8 @@ import qualified Data.List.NonEmpty as NE
-- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow ) -- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow )
-- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False } -- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False }
-- >>> dirs' <- getAllDirs -- >>> dirs' <- getAllDirs
-- >>> let installedVersions = [ ([pver|8.10.7|], Nothing), ([pver|8.10.4|], Nothing), ([pver|8.8.4|], Nothing), ([pver|8.8.3|], Nothing) ] -- >>> let installedVersions = [ ([pver|8.10.7|], "-debug+lol", Nothing), ([pver|8.10.4|], "", Nothing), ([pver|8.8.4|], "", Nothing), ([pver|8.8.3|], "", Nothing) ]
-- >>> let settings = Settings True False Never Curl False GHCupURL True GPGNone False -- >>> let settings = Settings True 0 False Never Curl False GHCupURL True GPGNone False
-- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc -- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
-- >>> cwd <- getCurrentDirectory -- >>> cwd <- getCurrentDirectory
-- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL) -- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
@@ -631,34 +632,34 @@ getGHCForPVP pvpIn mt = do
ghcs <- rights <$> getInstalledGHCs ghcs <- rights <$> getInstalledGHCs
-- we're permissive here... failed parse just means we have no match anyway -- we're permissive here... failed parse just means we have no match anyway
let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
pvp_ <- versionToPVP _tvVersion (pvp_, rest) <- versionToPVP _tvVersion
pure (pvp_, _tvTarget) pure (pvp_, rest, _tvTarget)
getGHCForPVP' pvpIn ghcs' mt getGHCForPVP' pvpIn ghcs' mt
-- | Like 'getGHCForPVP', except with explicit input parameter. -- | Like 'getGHCForPVP', except with explicit input parameter.
-- --
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing -- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
-- "Just 8.10.7" -- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}})
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing -- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
-- "Just 8.8.4" -- "Just 8.8.4"
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing -- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
-- "Just 8.10.4" -- "Just 8.10.4"
getGHCForPVP' :: MonadThrow m getGHCForPVP' :: MonadThrow m
=> PVP => PVP
-> [(PVP, Maybe Text)] -- ^ installed GHCs -> [(PVP, Text, Maybe Text)] -- ^ installed GHCs
-> Maybe Text -- ^ the target triple -> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
getGHCForPVP' pvpIn ghcs' mt = do getGHCForPVP' pvpIn ghcs' mt = do
let mResult = lastMay let mResult = lastMay
. sortBy (\(x, _) (y, _) -> compare x y) . sortBy (\(x, _, _) (y, _, _) -> compare x y)
. filter . filter
(\(pvp_, target) -> (\(pvp_, _, target) ->
target == mt && matchPVPrefix pvp_ pvpIn target == mt && matchPVPrefix pvp_ pvpIn
) )
$ ghcs' $ ghcs'
forM mResult $ \(pvp_, target) -> do forM mResult $ \(pvp_, rest, target) -> do
ver' <- pvpToVersion pvp_ ver' <- pvpToVersion pvp_ rest
pure (GHCTargetVersion target ver') pure (GHCTargetVersion target ver')
@@ -679,7 +680,7 @@ getLatestToolFor :: MonadThrow m
getLatestToolFor tool pvpIn dls = do getLatestToolFor tool pvpIn dls = do
let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
pure . headMay . filter (\(v, _) -> matchPVPrefix pvpIn v) $ ps pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps
@@ -855,6 +856,7 @@ make :: ( MonadThrow m
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, HasLog env
, HasSettings env , HasSettings env
) )
=> [String] => [String]
@@ -890,15 +892,22 @@ applyPatches pdir ddir = do
execBlank execBlank
([s|.+\.(patch|diff)$|] :: ByteString) ([s|.+\.(patch|diff)$|] :: ByteString)
) )
forM_ (sort patches) $ \patch' -> do forM_ (sort patches) $ \patch' -> applyPatch patch' ddir
lift $ logInfo $ "Applying patch " <> T.pack patch'
fmap (either (const Nothing) Just)
(exec applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
"patch" => FilePath -- ^ Patch
["-p1", "-i", patch'] -> FilePath -- ^ dir to apply patches in
(Just ddir) -> Excepts '[PatchFailed] m ()
Nothing) applyPatch patch ddir = do
!? PatchFailed lift $ logInfo $ "Applying patch " <> T.pack patch
fmap (either (const Nothing) Just)
(exec
"patch"
["-p1", "-s", "-f", "-i", patch]
(Just ddir)
Nothing)
!? PatchFailed
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353

View File

@@ -73,6 +73,7 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
execLogged :: ( MonadReader env m execLogged :: ( MonadReader env m
, HasSettings env , HasSettings env
, HasLog env
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadThrow m) , MonadThrow m)
@@ -85,6 +86,7 @@ execLogged :: ( MonadReader env m
execLogged exe args chdir lfile env = do execLogged exe args chdir lfile env = do
Settings {..} <- getSettings Settings {..} <- getSettings
Dirs {..} <- getDirs Dirs {..} <- getDirs
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
let logfile = logsDir </> lfile <> ".log" let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd closeFd

View File

@@ -18,6 +18,7 @@ module GHCup.Utils.File.Windows where
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.File.Common import GHCup.Utils.File.Common
import GHCup.Utils.Logger
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
@@ -40,6 +41,7 @@ import qualified Control.Exception as EX
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Text as T
@@ -149,6 +151,7 @@ executeOut path args chdir = do
execLogged :: ( MonadReader env m execLogged :: ( MonadReader env m
, HasDirs env , HasDirs env
, HasLog env
, HasSettings env , HasSettings env
, MonadIO m , MonadIO m
, MonadThrow m) , MonadThrow m)
@@ -160,6 +163,7 @@ execLogged :: ( MonadReader env m
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe args chdir lfile env = do execLogged exe args chdir lfile env = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
let stdoutLogfile = logsDir </> lfile <> ".stdout.log" let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log" stderrLogfile = logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args) cp <- createProcessWithMingwPath ((proc exe args)

View File

@@ -44,7 +44,7 @@ import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.Reader
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd ) import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
import Data.Maybe import Data.Maybe
import Data.Foldable import Data.Foldable
import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.List.NonEmpty ( NonEmpty( (:|) ))
@@ -313,18 +313,46 @@ removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str' maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
pvpToVersion :: MonadThrow m => PVP -> m Version pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
pvpToVersion = pvpToVersion pvp_ rest =
either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_
versionToPVP :: MonadThrow m => Version -> m PVP -- | Convert a version to a PVP and unparsable rest.
versionToPVP v = either (\_ -> alternative v) pure . pvp . prettyVer $ v --
-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v
where where
alternative :: MonadThrow m => Version -> m PVP alternative :: MonadThrow m => Version -> m PVP
alternative v' = case NE.takeWhile isDigit (_vChunks v') of alternative v' = case NE.takeWhile isDigit (_vChunks v') of
[] -> throwM $ ParseError "Couldn't convert Version to PVP" [] -> throwM $ ParseError "Couldn't convert Version to PVP"
xs -> pure $ pvpFromList (unsafeDigit <$> xs) xs -> pure $ pvpFromList (unsafeDigit <$> xs)
rest :: Version -> Text
rest (Version _ cs pr me) =
let chunks = NE.dropWhile isDigit cs
ver = intersperse (T.pack ".") . chunksAsT $ chunks
me' = maybe [] (\m -> [T.pack "+",m]) me
pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
prefix = case (ver, pr', me') of
(_:_, _, _) -> T.pack "."
_ -> T.pack ""
in prefix <> mconcat (ver <> pr' <> me')
where
chunksAsT :: Functor t => t VChunk -> t Text
chunksAsT = fmap (foldMap f)
where
f :: VUnit -> Text
f (Digits i) = T.pack $ show i
f (Str s) = s
foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
foldable d g f | null f = d
| otherwise = g f
isDigit :: VChunk -> Bool isDigit :: VChunk -> Bool
isDigit (Digits _ :| []) = True isDigit (Digits _ :| []) = True
isDigit _ = False isDigit _ = False

View File

@@ -53,6 +53,9 @@ deriving instance Data VUnit
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
deriving instance Lift (NonEmpty Word) deriving instance Lift (NonEmpty Word)
deriving instance Lift (NonEmpty VChunk)
deriving instance Lift (NonEmpty MChunk)
deriving instance Lift (NonEmpty VUnit)
#endif #endif
qq :: (Text -> Q Exp) -> QuasiQuoter qq :: (Text -> Q Exp) -> QuasiQuoter

View File

@@ -246,6 +246,7 @@ if ($Silent -and !($InstallDir)) {
$GhcupBasePrefix = ('{0}\' -f $GhcupBasePrefix) $GhcupBasePrefix = ('{0}\' -f $GhcupBasePrefix)
} }
$GhcupBasePrefix = $GhcupBasePrefix.TrimEnd().TrimStart()
if (!($GhcupBasePrefix)) { if (!($GhcupBasePrefix)) {
Print-Msg -color Red -msg "No directory specified!" Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Test-Path -LiteralPath ('{0}' -f $GhcupBasePrefix))) { } elseif (!(Test-Path -LiteralPath ('{0}' -f $GhcupBasePrefix))) {
@@ -333,6 +334,7 @@ if ($CabalDir) {
$CabalDirPrompt = Read-Host $CabalDirPrompt = Read-Host
$CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt] $CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt]
$CabDirEnv = $CabDirEnv.TrimEnd().TrimStart()
if (!($CabDirEnv)) { if (!($CabDirEnv)) {
Print-Msg -color Red -msg "No directory specified!" Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) { } elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
@@ -444,6 +446,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Print-Msg -color Magenta -msg 'Input existing MSys2 toolchain directory:' Print-Msg -color Magenta -msg 'Input existing MSys2 toolchain directory:'
$MsysDir = Read-Host $MsysDir = Read-Host
} }
$MsysDir = $MsysDir.TrimEnd().TrimStart()
if (!($MsysDir)) { if (!($MsysDir)) {
Print-Msg -color Red -msg "No directory specified!" Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Test-Path -LiteralPath ('{0}' -f $MsysDir))) { } elseif (!(Test-Path -LiteralPath ('{0}' -f $MsysDir))) {

View File

@@ -16,7 +16,6 @@ extra-deps:
- composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
- haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466 - haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298 - haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
- haskus-utils-variant-3.1@sha256:e602dd23e068c98d03c1027af20503addef8df6368577622453f44ccabea2a5b,2159
- heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340 - heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269 - hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615 - hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
@@ -40,6 +39,11 @@ extra-deps:
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- yaml-streamly-0.12.0 - yaml-streamly-0.12.0
- git: https://github.com/hasufell/packages.git
commit: cc0b4688f8bb374fa92f17c856949de795b56291
subdirs:
- haskus-utils-variant
flags: flags:
http-io-streams: http-io-streams:
brotli: false brotli: false

View File

@@ -3,7 +3,7 @@
module GHCup.Types.JSONSpec where module GHCup.Types.JSONSpec where
import GHCup.ArbitraryTypes () import GHCup.ArbitraryTypes ()
import GHCup.Types import GHCup.Types hiding ( defaultSettings )
import GHCup.Types.JSON () import GHCup.Types.JSON ()
import Test.Aeson.GenericSpecs import Test.Aeson.GenericSpecs