Compare commits
24 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
e74e746213
|
|||
|
065f9c4965
|
|||
|
32f3c36589
|
|||
|
c2a8d39fb4
|
|||
|
f08cbe70fb
|
|||
|
a9630d0802
|
|||
|
c5c6c431b5
|
|||
|
71d78d2d72
|
|||
|
ccecda2eff
|
|||
|
3a5f8d6139
|
|||
|
74e0f39bc2
|
|||
|
274978a8a7
|
|||
|
8eea9bd6a5
|
|||
|
626a2dd020
|
|||
|
6b6ce221e0
|
|||
|
d038c361c0
|
|||
|
c05876cc60
|
|||
|
b9c4c9a0b7
|
|||
|
6697e804ee
|
|||
|
2c57def8f1
|
|||
|
62b16e957b
|
|||
|
18d7bdd85c
|
|||
|
190b5dedba
|
|||
|
886e45f788
|
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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}" ]
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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"
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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:
|
||||||
|
|||||||
@@ -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`
|
||||||
|
|||||||
12
ghcup.cabal
12
ghcup.cabal
@@ -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
|
||||||
|
|||||||
2
hie.yaml
2
hie.yaml
@@ -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
|
||||||
|
|||||||
95
lib/GHCup.hs
95
lib/GHCup.hs
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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))) {
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
Reference in New Issue
Block a user